From b43eccd4cffed5bd1017c5821524fb6e49202f78 Mon Sep 17 00:00:00 2001 From: Sandeep Gupta Date: Sun, 18 Jun 2017 23:55:40 +0530 Subject: First commit --- 2.3-1/src/fortran/lapack/Makefile.am | 322 ++ 2.3-1/src/fortran/lapack/Makefile.in | 894 +++++ 2.3-1/src/fortran/lapack/README | 5 + 2.3-1/src/fortran/lapack/dbdsqr.f | 742 ++++ 2.3-1/src/fortran/lapack/dgebak.f | 188 + 2.3-1/src/fortran/lapack/dgebal.f | 322 ++ 2.3-1/src/fortran/lapack/dgebd2.f | 239 ++ 2.3-1/src/fortran/lapack/dgebrd.f | 268 ++ 2.3-1/src/fortran/lapack/dgecon.f | 185 + 2.3-1/src/fortran/lapack/dgeequ.f | 225 ++ 2.3-1/src/fortran/lapack/dgees.f | 434 +++ 2.3-1/src/fortran/lapack/dgeesx.f | 527 +++ 2.3-1/src/fortran/lapack/dgeev.f | 423 +++ 2.3-1/src/fortran/lapack/dgegs.f | 438 +++ 2.3-1/src/fortran/lapack/dgehd2.f | 149 + 2.3-1/src/fortran/lapack/dgehrd.f | 273 ++ 2.3-1/src/fortran/lapack/dgelq2.f | 121 + 2.3-1/src/fortran/lapack/dgelqf.f | 195 ++ 2.3-1/src/fortran/lapack/dgels.f | 422 +++ 2.3-1/src/fortran/lapack/dgelss.f | 617 ++++ 2.3-1/src/fortran/lapack/dgelsx.f | 349 ++ 2.3-1/src/fortran/lapack/dgelsy.f | 391 +++ 2.3-1/src/fortran/lapack/dgeql2.f | 122 + 2.3-1/src/fortran/lapack/dgeqlf.f | 213 ++ 2.3-1/src/fortran/lapack/dgeqp3.f | 287 ++ 2.3-1/src/fortran/lapack/dgeqpf.f | 231 ++ 2.3-1/src/fortran/lapack/dgeqr2.f | 121 + 2.3-1/src/fortran/lapack/dgeqrf.f | 196 ++ 2.3-1/src/fortran/lapack/dgerfs.f | 336 ++ 2.3-1/src/fortran/lapack/dgerq2.f | 122 + 2.3-1/src/fortran/lapack/dgerqf.f | 213 ++ 2.3-1/src/fortran/lapack/dgesc2.f | 132 + 2.3-1/src/fortran/lapack/dgesv.f | 107 + 2.3-1/src/fortran/lapack/dgesvd.f | 3401 ++++++++++++++++++ 2.3-1/src/fortran/lapack/dgesvx.f | 479 +++ 2.3-1/src/fortran/lapack/dgetc2.f | 146 + 2.3-1/src/fortran/lapack/dgetf2.f | 147 + 2.3-1/src/fortran/lapack/dgetrf.f | 159 + 2.3-1/src/fortran/lapack/dgetri.f | 192 ++ 2.3-1/src/fortran/lapack/dgetrs.f | 149 + 2.3-1/src/fortran/lapack/dggbak.f | 220 ++ 2.3-1/src/fortran/lapack/dggbal.f | 469 +++ 2.3-1/src/fortran/lapack/dgges.f | 550 +++ 2.3-1/src/fortran/lapack/dggev.f | 489 +++ 2.3-1/src/fortran/lapack/dgghrd.f | 264 ++ 2.3-1/src/fortran/lapack/dhgeqz.f | 1243 +++++++ 2.3-1/src/fortran/lapack/dhseqr.f | 407 +++ 2.3-1/src/fortran/lapack/disnan.f | 33 + 2.3-1/src/fortran/lapack/dlabad.f | 55 + 2.3-1/src/fortran/lapack/dlabrd.f | 290 ++ 2.3-1/src/fortran/lapack/dlacn2.f | 214 ++ 2.3-1/src/fortran/lapack/dlacon.f | 205 ++ 2.3-1/src/fortran/lapack/dlacpy.f | 87 + 2.3-1/src/fortran/lapack/dladiv.f | 62 + 2.3-1/src/fortran/lapack/dlae2.f | 123 + 2.3-1/src/fortran/lapack/dlaev2.f | 169 + 2.3-1/src/fortran/lapack/dlaexc.f | 354 ++ 2.3-1/src/fortran/lapack/dlag2.f | 300 ++ 2.3-1/src/fortran/lapack/dlagv2.f | 287 ++ 2.3-1/src/fortran/lapack/dlahqr.f | 501 +++ 2.3-1/src/fortran/lapack/dlahr2.f | 238 ++ 2.3-1/src/fortran/lapack/dlahrd.f | 207 ++ 2.3-1/src/fortran/lapack/dlaic1.f | 292 ++ 2.3-1/src/fortran/lapack/dlaisnan.f | 41 + 2.3-1/src/fortran/lapack/dlaln2.f | 507 +++ 2.3-1/src/fortran/lapack/dlamch.f | 857 +++++ 2.3-1/src/fortran/lapack/dlange.f | 144 + 2.3-1/src/fortran/lapack/dlanhs.f | 141 + 2.3-1/src/fortran/lapack/dlansp.f | 196 ++ 2.3-1/src/fortran/lapack/dlanst.f | 124 + 2.3-1/src/fortran/lapack/dlansy.f | 173 + 2.3-1/src/fortran/lapack/dlantr.f | 276 ++ 2.3-1/src/fortran/lapack/dlanv2.f | 205 ++ 2.3-1/src/fortran/lapack/dlapmt.f | 136 + 2.3-1/src/fortran/lapack/dlapy2.f | 53 + 2.3-1/src/fortran/lapack/dlapy3.f | 56 + 2.3-1/src/fortran/lapack/dlaqge.f | 154 + 2.3-1/src/fortran/lapack/dlaqp2.f | 175 + 2.3-1/src/fortran/lapack/dlaqps.f | 259 ++ 2.3-1/src/fortran/lapack/dlaqr0.f | 642 ++++ 2.3-1/src/fortran/lapack/dlaqr1.f | 97 + 2.3-1/src/fortran/lapack/dlaqr2.f | 551 +++ 2.3-1/src/fortran/lapack/dlaqr3.f | 561 +++ 2.3-1/src/fortran/lapack/dlaqr4.f | 640 ++++ 2.3-1/src/fortran/lapack/dlaqr5.f | 812 +++++ 2.3-1/src/fortran/lapack/dlarf.f | 115 + 2.3-1/src/fortran/lapack/dlarfb.f | 587 ++++ 2.3-1/src/fortran/lapack/dlarfg.f | 137 + 2.3-1/src/fortran/lapack/dlarft.f | 217 ++ 2.3-1/src/fortran/lapack/dlarfx.f | 638 ++++ 2.3-1/src/fortran/lapack/dlartg.f | 145 + 2.3-1/src/fortran/lapack/dlarz.f | 152 + 2.3-1/src/fortran/lapack/dlarzb.f | 220 ++ 2.3-1/src/fortran/lapack/dlarzt.f | 184 + 2.3-1/src/fortran/lapack/dlas2.f | 121 + 2.3-1/src/fortran/lapack/dlascl.f | 267 ++ 2.3-1/src/fortran/lapack/dlaset.f | 114 + 2.3-1/src/fortran/lapack/dlasq1.f | 148 + 2.3-1/src/fortran/lapack/dlasq2.f | 448 +++ 2.3-1/src/fortran/lapack/dlasq3.f | 295 ++ 2.3-1/src/fortran/lapack/dlasq4.f | 329 ++ 2.3-1/src/fortran/lapack/dlasq5.f | 195 ++ 2.3-1/src/fortran/lapack/dlasq6.f | 175 + 2.3-1/src/fortran/lapack/dlasr.f | 361 ++ 2.3-1/src/fortran/lapack/dlasrt.f | 243 ++ 2.3-1/src/fortran/lapack/dlassq.f | 88 + 2.3-1/src/fortran/lapack/dlasv2.f | 249 ++ 2.3-1/src/fortran/lapack/dlaswp.f | 119 + 2.3-1/src/fortran/lapack/dlasy2.f | 381 +++ 2.3-1/src/fortran/lapack/dlasyf.f | 587 ++++ 2.3-1/src/fortran/lapack/dlatdf.f | 237 ++ 2.3-1/src/fortran/lapack/dlatrd.f | 258 ++ 2.3-1/src/fortran/lapack/dlatrs.f | 701 ++++ 2.3-1/src/fortran/lapack/dlatrz.f | 127 + 2.3-1/src/fortran/lapack/dlatzm.f | 142 + 2.3-1/src/fortran/lapack/dlazq3.f | 302 ++ 2.3-1/src/fortran/lapack/dlazq4.f | 330 ++ 2.3-1/src/fortran/lapack/dopgtr.f | 160 + 2.3-1/src/fortran/lapack/dorg2l.f | 127 + 2.3-1/src/fortran/lapack/dorg2r.f | 129 + 2.3-1/src/fortran/lapack/dorgbr.f | 244 ++ 2.3-1/src/fortran/lapack/dorghr.f | 164 + 2.3-1/src/fortran/lapack/dorgl2.f | 133 + 2.3-1/src/fortran/lapack/dorglq.f | 215 ++ 2.3-1/src/fortran/lapack/dorgql.f | 222 ++ 2.3-1/src/fortran/lapack/dorgqr.f | 216 ++ 2.3-1/src/fortran/lapack/dorgr2.f | 131 + 2.3-1/src/fortran/lapack/dorgrq.f | 222 ++ 2.3-1/src/fortran/lapack/dorgtr.f | 183 + 2.3-1/src/fortran/lapack/dorm2l.f | 193 ++ 2.3-1/src/fortran/lapack/dorm2r.f | 197 ++ 2.3-1/src/fortran/lapack/dormbr.f | 281 ++ 2.3-1/src/fortran/lapack/dormhr.f | 201 ++ 2.3-1/src/fortran/lapack/dorml2.f | 197 ++ 2.3-1/src/fortran/lapack/dormlq.f | 267 ++ 2.3-1/src/fortran/lapack/dormql.f | 261 ++ 2.3-1/src/fortran/lapack/dormqr.f | 260 ++ 2.3-1/src/fortran/lapack/dormr2.f | 193 ++ 2.3-1/src/fortran/lapack/dormr3.f | 206 ++ 2.3-1/src/fortran/lapack/dormrq.f | 268 ++ 2.3-1/src/fortran/lapack/dormrz.f | 292 ++ 2.3-1/src/fortran/lapack/dpocon.f | 177 + 2.3-1/src/fortran/lapack/dpotf2.f | 167 + 2.3-1/src/fortran/lapack/dpotrf.f | 183 + 2.3-1/src/fortran/lapack/dpotrs.f | 132 + 2.3-1/src/fortran/lapack/dpptrf.f | 177 + 2.3-1/src/fortran/lapack/drscl.f | 114 + 2.3-1/src/fortran/lapack/dspev.f | 187 + 2.3-1/src/fortran/lapack/dspgst.f | 208 ++ 2.3-1/src/fortran/lapack/dspgv.f | 195 ++ 2.3-1/src/fortran/lapack/dsptrd.f | 228 ++ 2.3-1/src/fortran/lapack/dsptrf.f | 547 +++ 2.3-1/src/fortran/lapack/dsteqr.f | 500 +++ 2.3-1/src/fortran/lapack/dsterf.f | 364 ++ 2.3-1/src/fortran/lapack/dsycon.f | 165 + 2.3-1/src/fortran/lapack/dsyev.f | 211 ++ 2.3-1/src/fortran/lapack/dsysv.f | 174 + 2.3-1/src/fortran/lapack/dsytd2.f | 248 ++ 2.3-1/src/fortran/lapack/dsytf2.f | 521 +++ 2.3-1/src/fortran/lapack/dsytrd.f | 294 ++ 2.3-1/src/fortran/lapack/dsytrf.f | 287 ++ 2.3-1/src/fortran/lapack/dsytri.f | 312 ++ 2.3-1/src/fortran/lapack/dsytrs.f | 369 ++ 2.3-1/src/fortran/lapack/dtgevc.f | 1147 +++++++ 2.3-1/src/fortran/lapack/dtgex2.f | 581 ++++ 2.3-1/src/fortran/lapack/dtgexc.f | 440 +++ 2.3-1/src/fortran/lapack/dtgsen.f | 723 ++++ 2.3-1/src/fortran/lapack/dtgsy2.f | 956 ++++++ 2.3-1/src/fortran/lapack/dtgsyl.f | 556 +++ 2.3-1/src/fortran/lapack/dtrcon.f | 197 ++ 2.3-1/src/fortran/lapack/dtrevc.f | 980 ++++++ 2.3-1/src/fortran/lapack/dtrexc.f | 345 ++ 2.3-1/src/fortran/lapack/dtrsen.f | 459 +++ 2.3-1/src/fortran/lapack/dtrsyl.f | 913 +++++ 2.3-1/src/fortran/lapack/dtrti2.f | 146 + 2.3-1/src/fortran/lapack/dtrtri.f | 176 + 2.3-1/src/fortran/lapack/dtrtrs.f | 147 + 2.3-1/src/fortran/lapack/dtzrqf.f | 164 + 2.3-1/src/fortran/lapack/dtzrzf.f | 244 ++ 2.3-1/src/fortran/lapack/dzsum1.f | 81 + 2.3-1/src/fortran/lapack/ieeeck.f | 147 + 2.3-1/src/fortran/lapack/ilaenv.f | 552 +++ 2.3-1/src/fortran/lapack/iparmq.f | 253 ++ 2.3-1/src/fortran/lapack/izmax1.f | 95 + 2.3-1/src/fortran/lapack/lapack_f/lapack.def | 306 ++ 2.3-1/src/fortran/lapack/lapack_f/lapack_DLL.suo | Bin 0 -> 3072 bytes .../src/fortran/lapack/lapack_f/lapack_DLL.vfproj | 352 ++ .../fortran/lapack/lapack_f/lapack_DLL_f2c.vcxproj | 837 +++++ .../lapack/lapack_f/lapack_DLL_f2c.vcxproj.filters | 1782 ++++++++++ 2.3-1/src/fortran/lapack/lsame.f | 87 + 2.3-1/src/fortran/lapack/slamch.f | 857 +++++ 2.3-1/src/fortran/lapack/xerbla.f | 45 + 2.3-1/src/fortran/lapack/zbdsqr.f | 742 ++++ 2.3-1/src/fortran/lapack/zdrot.f | 96 + 2.3-1/src/fortran/lapack/zdrscl.f | 114 + 2.3-1/src/fortran/lapack/zgebak.f | 189 + 2.3-1/src/fortran/lapack/zgebal.f | 330 ++ 2.3-1/src/fortran/lapack/zgebd2.f | 250 ++ 2.3-1/src/fortran/lapack/zgebrd.f | 268 ++ 2.3-1/src/fortran/lapack/zgecon.f | 193 ++ 2.3-1/src/fortran/lapack/zgees.f | 324 ++ 2.3-1/src/fortran/lapack/zgeev.f | 396 +++ 2.3-1/src/fortran/lapack/zgehd2.f | 148 + 2.3-1/src/fortran/lapack/zgehrd.f | 273 ++ 2.3-1/src/fortran/lapack/zgelq2.f | 123 + 2.3-1/src/fortran/lapack/zgelqf.f | 195 ++ 2.3-1/src/fortran/lapack/zgelsy.f | 385 +++ 2.3-1/src/fortran/lapack/zgeqp3.f | 293 ++ 2.3-1/src/fortran/lapack/zgeqpf.f | 234 ++ 2.3-1/src/fortran/lapack/zgeqr2.f | 121 + 2.3-1/src/fortran/lapack/zgeqrf.f | 196 ++ 2.3-1/src/fortran/lapack/zgesc2.f | 133 + 2.3-1/src/fortran/lapack/zgesvd.f | 3602 ++++++++++++++++++++ 2.3-1/src/fortran/lapack/zgetc2.f | 145 + 2.3-1/src/fortran/lapack/zgetf2.f | 148 + 2.3-1/src/fortran/lapack/zgetrf.f | 159 + 2.3-1/src/fortran/lapack/zgetri.f | 193 ++ 2.3-1/src/fortran/lapack/zgetrs.f | 149 + 2.3-1/src/fortran/lapack/zggbak.f | 220 ++ 2.3-1/src/fortran/lapack/zggbal.f | 482 +++ 2.3-1/src/fortran/lapack/zgges.f | 477 +++ 2.3-1/src/fortran/lapack/zggev.f | 454 +++ 2.3-1/src/fortran/lapack/zgghrd.f | 264 ++ 2.3-1/src/fortran/lapack/zheev.f | 218 ++ 2.3-1/src/fortran/lapack/zhetd2.f | 258 ++ 2.3-1/src/fortran/lapack/zhetrd.f | 296 ++ 2.3-1/src/fortran/lapack/zhgeqz.f | 759 +++++ 2.3-1/src/fortran/lapack/zhseqr.f | 395 +++ 2.3-1/src/fortran/lapack/zlabrd.f | 328 ++ 2.3-1/src/fortran/lapack/zlacgv.f | 60 + 2.3-1/src/fortran/lapack/zlacn2.f | 221 ++ 2.3-1/src/fortran/lapack/zlacon.f | 212 ++ 2.3-1/src/fortran/lapack/zlacpy.f | 90 + 2.3-1/src/fortran/lapack/zladiv.f | 46 + 2.3-1/src/fortran/lapack/zlahqr.f | 470 +++ 2.3-1/src/fortran/lapack/zlahr2.f | 240 ++ 2.3-1/src/fortran/lapack/zlahrd.f | 213 ++ 2.3-1/src/fortran/lapack/zlaic1.f | 295 ++ 2.3-1/src/fortran/lapack/zlange.f | 145 + 2.3-1/src/fortran/lapack/zlanhe.f | 187 + 2.3-1/src/fortran/lapack/zlanhs.f | 142 + 2.3-1/src/fortran/lapack/zlaqp2.f | 179 + 2.3-1/src/fortran/lapack/zlaqps.f | 266 ++ 2.3-1/src/fortran/lapack/zlaqr0.f | 601 ++++ 2.3-1/src/fortran/lapack/zlaqr1.f | 97 + 2.3-1/src/fortran/lapack/zlaqr2.f | 437 +++ 2.3-1/src/fortran/lapack/zlaqr3.f | 448 +++ 2.3-1/src/fortran/lapack/zlaqr4.f | 602 ++++ 2.3-1/src/fortran/lapack/zlaqr5.f | 809 +++++ 2.3-1/src/fortran/lapack/zlarf.f | 120 + 2.3-1/src/fortran/lapack/zlarfb.f | 608 ++++ 2.3-1/src/fortran/lapack/zlarfg.f | 145 + 2.3-1/src/fortran/lapack/zlarft.f | 224 ++ 2.3-1/src/fortran/lapack/zlarfx.f | 641 ++++ 2.3-1/src/fortran/lapack/zlartg.f | 195 ++ 2.3-1/src/fortran/lapack/zlarz.f | 157 + 2.3-1/src/fortran/lapack/zlarzb.f | 234 ++ 2.3-1/src/fortran/lapack/zlarzt.f | 186 + 2.3-1/src/fortran/lapack/zlascl.f | 267 ++ 2.3-1/src/fortran/lapack/zlaset.f | 114 + 2.3-1/src/fortran/lapack/zlasr.f | 363 ++ 2.3-1/src/fortran/lapack/zlassq.f | 101 + 2.3-1/src/fortran/lapack/zlaswp.f | 119 + 2.3-1/src/fortran/lapack/zlatdf.f | 241 ++ 2.3-1/src/fortran/lapack/zlatrd.f | 279 ++ 2.3-1/src/fortran/lapack/zlatrs.f | 879 +++++ 2.3-1/src/fortran/lapack/zlatrz.f | 133 + 2.3-1/src/fortran/lapack/zpotf2.f | 174 + 2.3-1/src/fortran/lapack/zpotrf.f | 186 + 2.3-1/src/fortran/lapack/zrot.f | 91 + 2.3-1/src/fortran/lapack/zsteqr.f | 503 +++ 2.3-1/src/fortran/lapack/ztgevc.f | 633 ++++ 2.3-1/src/fortran/lapack/ztgex2.f | 265 ++ 2.3-1/src/fortran/lapack/ztgexc.f | 206 ++ 2.3-1/src/fortran/lapack/ztgsen.f | 652 ++++ 2.3-1/src/fortran/lapack/ztgsy2.f | 361 ++ 2.3-1/src/fortran/lapack/ztgsyl.f | 575 ++++ 2.3-1/src/fortran/lapack/ztrevc.f | 386 +++ 2.3-1/src/fortran/lapack/ztrexc.f | 162 + 2.3-1/src/fortran/lapack/ztrsen.f | 359 ++ 2.3-1/src/fortran/lapack/ztrsyl.f | 365 ++ 2.3-1/src/fortran/lapack/ztrti2.f | 146 + 2.3-1/src/fortran/lapack/ztrtri.f | 177 + 2.3-1/src/fortran/lapack/ztzrzf.f | 244 ++ 2.3-1/src/fortran/lapack/zung2l.f | 128 + 2.3-1/src/fortran/lapack/zung2r.f | 130 + 2.3-1/src/fortran/lapack/zungbr.f | 245 ++ 2.3-1/src/fortran/lapack/zunghr.f | 165 + 2.3-1/src/fortran/lapack/zungl2.f | 136 + 2.3-1/src/fortran/lapack/zunglq.f | 215 ++ 2.3-1/src/fortran/lapack/zungql.f | 222 ++ 2.3-1/src/fortran/lapack/zungqr.f | 216 ++ 2.3-1/src/fortran/lapack/zungtr.f | 184 + 2.3-1/src/fortran/lapack/zunm2r.f | 201 ++ 2.3-1/src/fortran/lapack/zunmbr.f | 288 ++ 2.3-1/src/fortran/lapack/zunml2.f | 205 ++ 2.3-1/src/fortran/lapack/zunmlq.f | 267 ++ 2.3-1/src/fortran/lapack/zunmqr.f | 260 ++ 2.3-1/src/fortran/lapack/zunmr3.f | 212 ++ 2.3-1/src/fortran/lapack/zunmrz.f | 296 ++ 300 files changed, 94414 insertions(+) create mode 100644 2.3-1/src/fortran/lapack/Makefile.am create mode 100644 2.3-1/src/fortran/lapack/Makefile.in create mode 100644 2.3-1/src/fortran/lapack/README create mode 100644 2.3-1/src/fortran/lapack/dbdsqr.f create mode 100644 2.3-1/src/fortran/lapack/dgebak.f create mode 100644 2.3-1/src/fortran/lapack/dgebal.f create mode 100644 2.3-1/src/fortran/lapack/dgebd2.f create mode 100644 2.3-1/src/fortran/lapack/dgebrd.f create mode 100644 2.3-1/src/fortran/lapack/dgecon.f create mode 100644 2.3-1/src/fortran/lapack/dgeequ.f create mode 100644 2.3-1/src/fortran/lapack/dgees.f create mode 100644 2.3-1/src/fortran/lapack/dgeesx.f create mode 100644 2.3-1/src/fortran/lapack/dgeev.f create mode 100644 2.3-1/src/fortran/lapack/dgegs.f create mode 100644 2.3-1/src/fortran/lapack/dgehd2.f create mode 100644 2.3-1/src/fortran/lapack/dgehrd.f create mode 100644 2.3-1/src/fortran/lapack/dgelq2.f create mode 100644 2.3-1/src/fortran/lapack/dgelqf.f create mode 100644 2.3-1/src/fortran/lapack/dgels.f create mode 100644 2.3-1/src/fortran/lapack/dgelss.f create mode 100644 2.3-1/src/fortran/lapack/dgelsx.f create mode 100644 2.3-1/src/fortran/lapack/dgelsy.f create mode 100644 2.3-1/src/fortran/lapack/dgeql2.f create mode 100644 2.3-1/src/fortran/lapack/dgeqlf.f create mode 100644 2.3-1/src/fortran/lapack/dgeqp3.f create mode 100644 2.3-1/src/fortran/lapack/dgeqpf.f create mode 100644 2.3-1/src/fortran/lapack/dgeqr2.f create mode 100644 2.3-1/src/fortran/lapack/dgeqrf.f create mode 100644 2.3-1/src/fortran/lapack/dgerfs.f create mode 100644 2.3-1/src/fortran/lapack/dgerq2.f create mode 100644 2.3-1/src/fortran/lapack/dgerqf.f create mode 100644 2.3-1/src/fortran/lapack/dgesc2.f create mode 100644 2.3-1/src/fortran/lapack/dgesv.f create mode 100644 2.3-1/src/fortran/lapack/dgesvd.f create mode 100644 2.3-1/src/fortran/lapack/dgesvx.f create mode 100644 2.3-1/src/fortran/lapack/dgetc2.f create mode 100644 2.3-1/src/fortran/lapack/dgetf2.f create mode 100644 2.3-1/src/fortran/lapack/dgetrf.f create mode 100644 2.3-1/src/fortran/lapack/dgetri.f create mode 100644 2.3-1/src/fortran/lapack/dgetrs.f create mode 100644 2.3-1/src/fortran/lapack/dggbak.f create mode 100644 2.3-1/src/fortran/lapack/dggbal.f create mode 100644 2.3-1/src/fortran/lapack/dgges.f create mode 100644 2.3-1/src/fortran/lapack/dggev.f create mode 100644 2.3-1/src/fortran/lapack/dgghrd.f create mode 100644 2.3-1/src/fortran/lapack/dhgeqz.f create mode 100644 2.3-1/src/fortran/lapack/dhseqr.f create mode 100644 2.3-1/src/fortran/lapack/disnan.f create mode 100644 2.3-1/src/fortran/lapack/dlabad.f create mode 100644 2.3-1/src/fortran/lapack/dlabrd.f create mode 100644 2.3-1/src/fortran/lapack/dlacn2.f create mode 100644 2.3-1/src/fortran/lapack/dlacon.f create mode 100644 2.3-1/src/fortran/lapack/dlacpy.f create mode 100644 2.3-1/src/fortran/lapack/dladiv.f create mode 100644 2.3-1/src/fortran/lapack/dlae2.f create mode 100644 2.3-1/src/fortran/lapack/dlaev2.f create mode 100644 2.3-1/src/fortran/lapack/dlaexc.f create mode 100644 2.3-1/src/fortran/lapack/dlag2.f create mode 100644 2.3-1/src/fortran/lapack/dlagv2.f create mode 100644 2.3-1/src/fortran/lapack/dlahqr.f create mode 100644 2.3-1/src/fortran/lapack/dlahr2.f create mode 100644 2.3-1/src/fortran/lapack/dlahrd.f create mode 100644 2.3-1/src/fortran/lapack/dlaic1.f create mode 100644 2.3-1/src/fortran/lapack/dlaisnan.f create mode 100644 2.3-1/src/fortran/lapack/dlaln2.f create mode 100644 2.3-1/src/fortran/lapack/dlamch.f create mode 100644 2.3-1/src/fortran/lapack/dlange.f create mode 100644 2.3-1/src/fortran/lapack/dlanhs.f create mode 100644 2.3-1/src/fortran/lapack/dlansp.f create mode 100644 2.3-1/src/fortran/lapack/dlanst.f create mode 100644 2.3-1/src/fortran/lapack/dlansy.f create mode 100644 2.3-1/src/fortran/lapack/dlantr.f create mode 100644 2.3-1/src/fortran/lapack/dlanv2.f create mode 100644 2.3-1/src/fortran/lapack/dlapmt.f create mode 100644 2.3-1/src/fortran/lapack/dlapy2.f create mode 100644 2.3-1/src/fortran/lapack/dlapy3.f create mode 100644 2.3-1/src/fortran/lapack/dlaqge.f create mode 100644 2.3-1/src/fortran/lapack/dlaqp2.f create mode 100644 2.3-1/src/fortran/lapack/dlaqps.f create mode 100644 2.3-1/src/fortran/lapack/dlaqr0.f create mode 100644 2.3-1/src/fortran/lapack/dlaqr1.f create mode 100644 2.3-1/src/fortran/lapack/dlaqr2.f create mode 100644 2.3-1/src/fortran/lapack/dlaqr3.f create mode 100644 2.3-1/src/fortran/lapack/dlaqr4.f create mode 100644 2.3-1/src/fortran/lapack/dlaqr5.f create mode 100644 2.3-1/src/fortran/lapack/dlarf.f create mode 100644 2.3-1/src/fortran/lapack/dlarfb.f create mode 100644 2.3-1/src/fortran/lapack/dlarfg.f create mode 100644 2.3-1/src/fortran/lapack/dlarft.f create mode 100644 2.3-1/src/fortran/lapack/dlarfx.f create mode 100644 2.3-1/src/fortran/lapack/dlartg.f create mode 100644 2.3-1/src/fortran/lapack/dlarz.f create mode 100644 2.3-1/src/fortran/lapack/dlarzb.f create mode 100644 2.3-1/src/fortran/lapack/dlarzt.f create mode 100644 2.3-1/src/fortran/lapack/dlas2.f create mode 100644 2.3-1/src/fortran/lapack/dlascl.f create mode 100644 2.3-1/src/fortran/lapack/dlaset.f create mode 100644 2.3-1/src/fortran/lapack/dlasq1.f create mode 100644 2.3-1/src/fortran/lapack/dlasq2.f create mode 100644 2.3-1/src/fortran/lapack/dlasq3.f create mode 100644 2.3-1/src/fortran/lapack/dlasq4.f create mode 100644 2.3-1/src/fortran/lapack/dlasq5.f create mode 100644 2.3-1/src/fortran/lapack/dlasq6.f create mode 100644 2.3-1/src/fortran/lapack/dlasr.f create mode 100644 2.3-1/src/fortran/lapack/dlasrt.f create mode 100644 2.3-1/src/fortran/lapack/dlassq.f create mode 100644 2.3-1/src/fortran/lapack/dlasv2.f create mode 100644 2.3-1/src/fortran/lapack/dlaswp.f create mode 100644 2.3-1/src/fortran/lapack/dlasy2.f create mode 100644 2.3-1/src/fortran/lapack/dlasyf.f create mode 100644 2.3-1/src/fortran/lapack/dlatdf.f create mode 100644 2.3-1/src/fortran/lapack/dlatrd.f create mode 100644 2.3-1/src/fortran/lapack/dlatrs.f create mode 100644 2.3-1/src/fortran/lapack/dlatrz.f create mode 100644 2.3-1/src/fortran/lapack/dlatzm.f create mode 100644 2.3-1/src/fortran/lapack/dlazq3.f create mode 100644 2.3-1/src/fortran/lapack/dlazq4.f create mode 100644 2.3-1/src/fortran/lapack/dopgtr.f create mode 100644 2.3-1/src/fortran/lapack/dorg2l.f create mode 100644 2.3-1/src/fortran/lapack/dorg2r.f create mode 100644 2.3-1/src/fortran/lapack/dorgbr.f create mode 100644 2.3-1/src/fortran/lapack/dorghr.f create mode 100644 2.3-1/src/fortran/lapack/dorgl2.f create mode 100644 2.3-1/src/fortran/lapack/dorglq.f create mode 100644 2.3-1/src/fortran/lapack/dorgql.f create mode 100644 2.3-1/src/fortran/lapack/dorgqr.f create mode 100644 2.3-1/src/fortran/lapack/dorgr2.f create mode 100644 2.3-1/src/fortran/lapack/dorgrq.f create mode 100644 2.3-1/src/fortran/lapack/dorgtr.f create mode 100644 2.3-1/src/fortran/lapack/dorm2l.f create mode 100644 2.3-1/src/fortran/lapack/dorm2r.f create mode 100644 2.3-1/src/fortran/lapack/dormbr.f create mode 100644 2.3-1/src/fortran/lapack/dormhr.f create mode 100644 2.3-1/src/fortran/lapack/dorml2.f create mode 100644 2.3-1/src/fortran/lapack/dormlq.f create mode 100644 2.3-1/src/fortran/lapack/dormql.f create mode 100644 2.3-1/src/fortran/lapack/dormqr.f create mode 100644 2.3-1/src/fortran/lapack/dormr2.f create mode 100644 2.3-1/src/fortran/lapack/dormr3.f create mode 100644 2.3-1/src/fortran/lapack/dormrq.f create mode 100644 2.3-1/src/fortran/lapack/dormrz.f create mode 100644 2.3-1/src/fortran/lapack/dpocon.f create mode 100644 2.3-1/src/fortran/lapack/dpotf2.f create mode 100644 2.3-1/src/fortran/lapack/dpotrf.f create mode 100644 2.3-1/src/fortran/lapack/dpotrs.f create mode 100644 2.3-1/src/fortran/lapack/dpptrf.f create mode 100644 2.3-1/src/fortran/lapack/drscl.f create mode 100644 2.3-1/src/fortran/lapack/dspev.f create mode 100644 2.3-1/src/fortran/lapack/dspgst.f create mode 100644 2.3-1/src/fortran/lapack/dspgv.f create mode 100644 2.3-1/src/fortran/lapack/dsptrd.f create mode 100644 2.3-1/src/fortran/lapack/dsptrf.f create mode 100644 2.3-1/src/fortran/lapack/dsteqr.f create mode 100644 2.3-1/src/fortran/lapack/dsterf.f create mode 100644 2.3-1/src/fortran/lapack/dsycon.f create mode 100644 2.3-1/src/fortran/lapack/dsyev.f create mode 100644 2.3-1/src/fortran/lapack/dsysv.f create mode 100644 2.3-1/src/fortran/lapack/dsytd2.f create mode 100644 2.3-1/src/fortran/lapack/dsytf2.f create mode 100644 2.3-1/src/fortran/lapack/dsytrd.f create mode 100644 2.3-1/src/fortran/lapack/dsytrf.f create mode 100644 2.3-1/src/fortran/lapack/dsytri.f create mode 100644 2.3-1/src/fortran/lapack/dsytrs.f create mode 100644 2.3-1/src/fortran/lapack/dtgevc.f create mode 100644 2.3-1/src/fortran/lapack/dtgex2.f create mode 100644 2.3-1/src/fortran/lapack/dtgexc.f create mode 100644 2.3-1/src/fortran/lapack/dtgsen.f create mode 100644 2.3-1/src/fortran/lapack/dtgsy2.f create mode 100644 2.3-1/src/fortran/lapack/dtgsyl.f create mode 100644 2.3-1/src/fortran/lapack/dtrcon.f create mode 100644 2.3-1/src/fortran/lapack/dtrevc.f create mode 100644 2.3-1/src/fortran/lapack/dtrexc.f create mode 100644 2.3-1/src/fortran/lapack/dtrsen.f create mode 100644 2.3-1/src/fortran/lapack/dtrsyl.f create mode 100644 2.3-1/src/fortran/lapack/dtrti2.f create mode 100644 2.3-1/src/fortran/lapack/dtrtri.f create mode 100644 2.3-1/src/fortran/lapack/dtrtrs.f create mode 100644 2.3-1/src/fortran/lapack/dtzrqf.f create mode 100644 2.3-1/src/fortran/lapack/dtzrzf.f create mode 100644 2.3-1/src/fortran/lapack/dzsum1.f create mode 100644 2.3-1/src/fortran/lapack/ieeeck.f create mode 100644 2.3-1/src/fortran/lapack/ilaenv.f create mode 100644 2.3-1/src/fortran/lapack/iparmq.f create mode 100644 2.3-1/src/fortran/lapack/izmax1.f create mode 100644 2.3-1/src/fortran/lapack/lapack_f/lapack.def create mode 100644 2.3-1/src/fortran/lapack/lapack_f/lapack_DLL.suo create mode 100644 2.3-1/src/fortran/lapack/lapack_f/lapack_DLL.vfproj create mode 100644 2.3-1/src/fortran/lapack/lapack_f/lapack_DLL_f2c.vcxproj create mode 100644 2.3-1/src/fortran/lapack/lapack_f/lapack_DLL_f2c.vcxproj.filters create mode 100644 2.3-1/src/fortran/lapack/lsame.f create mode 100644 2.3-1/src/fortran/lapack/slamch.f create mode 100644 2.3-1/src/fortran/lapack/xerbla.f create mode 100644 2.3-1/src/fortran/lapack/zbdsqr.f create mode 100644 2.3-1/src/fortran/lapack/zdrot.f create mode 100644 2.3-1/src/fortran/lapack/zdrscl.f create mode 100644 2.3-1/src/fortran/lapack/zgebak.f create mode 100644 2.3-1/src/fortran/lapack/zgebal.f create mode 100644 2.3-1/src/fortran/lapack/zgebd2.f create mode 100644 2.3-1/src/fortran/lapack/zgebrd.f create mode 100644 2.3-1/src/fortran/lapack/zgecon.f create mode 100644 2.3-1/src/fortran/lapack/zgees.f create mode 100644 2.3-1/src/fortran/lapack/zgeev.f create mode 100644 2.3-1/src/fortran/lapack/zgehd2.f create mode 100644 2.3-1/src/fortran/lapack/zgehrd.f create mode 100644 2.3-1/src/fortran/lapack/zgelq2.f create mode 100644 2.3-1/src/fortran/lapack/zgelqf.f create mode 100644 2.3-1/src/fortran/lapack/zgelsy.f create mode 100644 2.3-1/src/fortran/lapack/zgeqp3.f create mode 100644 2.3-1/src/fortran/lapack/zgeqpf.f create mode 100644 2.3-1/src/fortran/lapack/zgeqr2.f create mode 100644 2.3-1/src/fortran/lapack/zgeqrf.f create mode 100644 2.3-1/src/fortran/lapack/zgesc2.f create mode 100644 2.3-1/src/fortran/lapack/zgesvd.f create mode 100644 2.3-1/src/fortran/lapack/zgetc2.f create mode 100644 2.3-1/src/fortran/lapack/zgetf2.f create mode 100644 2.3-1/src/fortran/lapack/zgetrf.f create mode 100644 2.3-1/src/fortran/lapack/zgetri.f create mode 100644 2.3-1/src/fortran/lapack/zgetrs.f create mode 100644 2.3-1/src/fortran/lapack/zggbak.f create mode 100644 2.3-1/src/fortran/lapack/zggbal.f create mode 100644 2.3-1/src/fortran/lapack/zgges.f create mode 100644 2.3-1/src/fortran/lapack/zggev.f create mode 100644 2.3-1/src/fortran/lapack/zgghrd.f create mode 100644 2.3-1/src/fortran/lapack/zheev.f create mode 100644 2.3-1/src/fortran/lapack/zhetd2.f create mode 100644 2.3-1/src/fortran/lapack/zhetrd.f create mode 100644 2.3-1/src/fortran/lapack/zhgeqz.f create mode 100644 2.3-1/src/fortran/lapack/zhseqr.f create mode 100644 2.3-1/src/fortran/lapack/zlabrd.f create mode 100644 2.3-1/src/fortran/lapack/zlacgv.f create mode 100644 2.3-1/src/fortran/lapack/zlacn2.f create mode 100644 2.3-1/src/fortran/lapack/zlacon.f create mode 100644 2.3-1/src/fortran/lapack/zlacpy.f create mode 100644 2.3-1/src/fortran/lapack/zladiv.f create mode 100644 2.3-1/src/fortran/lapack/zlahqr.f create mode 100644 2.3-1/src/fortran/lapack/zlahr2.f create mode 100644 2.3-1/src/fortran/lapack/zlahrd.f create mode 100644 2.3-1/src/fortran/lapack/zlaic1.f create mode 100644 2.3-1/src/fortran/lapack/zlange.f create mode 100644 2.3-1/src/fortran/lapack/zlanhe.f create mode 100644 2.3-1/src/fortran/lapack/zlanhs.f create mode 100644 2.3-1/src/fortran/lapack/zlaqp2.f create mode 100644 2.3-1/src/fortran/lapack/zlaqps.f create mode 100644 2.3-1/src/fortran/lapack/zlaqr0.f create mode 100644 2.3-1/src/fortran/lapack/zlaqr1.f create mode 100644 2.3-1/src/fortran/lapack/zlaqr2.f create mode 100644 2.3-1/src/fortran/lapack/zlaqr3.f create mode 100644 2.3-1/src/fortran/lapack/zlaqr4.f create mode 100644 2.3-1/src/fortran/lapack/zlaqr5.f create mode 100644 2.3-1/src/fortran/lapack/zlarf.f create mode 100644 2.3-1/src/fortran/lapack/zlarfb.f create mode 100644 2.3-1/src/fortran/lapack/zlarfg.f create mode 100644 2.3-1/src/fortran/lapack/zlarft.f create mode 100644 2.3-1/src/fortran/lapack/zlarfx.f create mode 100644 2.3-1/src/fortran/lapack/zlartg.f create mode 100644 2.3-1/src/fortran/lapack/zlarz.f create mode 100644 2.3-1/src/fortran/lapack/zlarzb.f create mode 100644 2.3-1/src/fortran/lapack/zlarzt.f create mode 100644 2.3-1/src/fortran/lapack/zlascl.f create mode 100644 2.3-1/src/fortran/lapack/zlaset.f create mode 100644 2.3-1/src/fortran/lapack/zlasr.f create mode 100644 2.3-1/src/fortran/lapack/zlassq.f create mode 100644 2.3-1/src/fortran/lapack/zlaswp.f create mode 100644 2.3-1/src/fortran/lapack/zlatdf.f create mode 100644 2.3-1/src/fortran/lapack/zlatrd.f create mode 100644 2.3-1/src/fortran/lapack/zlatrs.f create mode 100644 2.3-1/src/fortran/lapack/zlatrz.f create mode 100644 2.3-1/src/fortran/lapack/zpotf2.f create mode 100644 2.3-1/src/fortran/lapack/zpotrf.f create mode 100644 2.3-1/src/fortran/lapack/zrot.f create mode 100644 2.3-1/src/fortran/lapack/zsteqr.f create mode 100644 2.3-1/src/fortran/lapack/ztgevc.f create mode 100644 2.3-1/src/fortran/lapack/ztgex2.f create mode 100644 2.3-1/src/fortran/lapack/ztgexc.f create mode 100644 2.3-1/src/fortran/lapack/ztgsen.f create mode 100644 2.3-1/src/fortran/lapack/ztgsy2.f create mode 100644 2.3-1/src/fortran/lapack/ztgsyl.f create mode 100644 2.3-1/src/fortran/lapack/ztrevc.f create mode 100644 2.3-1/src/fortran/lapack/ztrexc.f create mode 100644 2.3-1/src/fortran/lapack/ztrsen.f create mode 100644 2.3-1/src/fortran/lapack/ztrsyl.f create mode 100644 2.3-1/src/fortran/lapack/ztrti2.f create mode 100644 2.3-1/src/fortran/lapack/ztrtri.f create mode 100644 2.3-1/src/fortran/lapack/ztzrzf.f create mode 100644 2.3-1/src/fortran/lapack/zung2l.f create mode 100644 2.3-1/src/fortran/lapack/zung2r.f create mode 100644 2.3-1/src/fortran/lapack/zungbr.f create mode 100644 2.3-1/src/fortran/lapack/zunghr.f create mode 100644 2.3-1/src/fortran/lapack/zungl2.f create mode 100644 2.3-1/src/fortran/lapack/zunglq.f create mode 100644 2.3-1/src/fortran/lapack/zungql.f create mode 100644 2.3-1/src/fortran/lapack/zungqr.f create mode 100644 2.3-1/src/fortran/lapack/zungtr.f create mode 100644 2.3-1/src/fortran/lapack/zunm2r.f create mode 100644 2.3-1/src/fortran/lapack/zunmbr.f create mode 100644 2.3-1/src/fortran/lapack/zunml2.f create mode 100644 2.3-1/src/fortran/lapack/zunmlq.f create mode 100644 2.3-1/src/fortran/lapack/zunmqr.f create mode 100644 2.3-1/src/fortran/lapack/zunmr3.f create mode 100644 2.3-1/src/fortran/lapack/zunmrz.f (limited to '2.3-1/src/fortran/lapack') diff --git a/2.3-1/src/fortran/lapack/Makefile.am b/2.3-1/src/fortran/lapack/Makefile.am new file mode 100644 index 00000000..4bfc54d6 --- /dev/null +++ b/2.3-1/src/fortran/lapack/Makefile.am @@ -0,0 +1,322 @@ +########## +### Sylvestre Ledru +### INRIA - Scilab 2006 +########## + +#### Target ###### +modulename=lapack + +pkglib_LTLIBRARIES = libscilapack.la + +noinst_LTLIBRARIES = libdummy-lapack.la + +LAPACK_FORTRAN_SOURCES = dlasv2.f \ +zgeqpf.f \ +zrot.f \ +dpotrf.f \ +zunmr3.f \ +zlanhs.f \ +zgebak.f \ +zbdsqr.f \ +zunmrz.f \ +dgetc2.f \ +zlaqp2.f \ +dsytrd.f \ +dsytd2.f \ +zlange.f \ +dlansp.f \ +dhgeqz.f \ +dlasq2.f \ +dtrevc.f \ +dgelsy.f \ +zladiv.f \ +dlaswp.f \ +dormlq.f \ +dorml2.f \ +dlaexc.f \ +zlahqr.f \ +zdrot.f \ +dlabad.f \ +dlarft.f \ +zlassq.f \ +dlartg.f \ +zlarf.f \ +ztrexc.f \ +zgeev.f \ +dggbal.f \ +dtrtrs.f \ +zlatdf.f \ +dgeqr2.f \ +zlarfg.f \ +dgetrs.f \ +dlag2.f \ +dlaqge.f \ +dpotf2.f \ +zgetrf.f \ +ztgsy2.f \ +zgebal.f \ +dspgst.f \ +dormqr.f \ +drscl.f \ +dtrti2.f \ +dlaset.f \ +dgeesx.f \ +dpocon.f \ +dlasyf.f \ +dgerq2.f \ +dlasq3.f \ +dlansy.f \ +dgehrd.f \ +dgehd2.f \ +dsptrd.f \ +dorgtr.f \ +dormrq.f \ +dorm2r.f \ +dormr2.f \ +zgges.f \ +zunglq.f \ +zlanhe.f \ +zungl2.f \ +zhetrd.f \ +zhetd2.f \ +dlacon.f \ +dgesvx.f \ +zgetf2.f \ +ztgevc.f \ +dsteqr.f \ +dgelqf.f \ +zlarzb.f \ +zlarfx.f \ +dsysv.f \ +zlaqps.f \ +dtzrqf.f \ +dsytrf.f \ +xerbla.f \ +dtrsyl.f \ +dgelss.f \ +dtgsen.f \ +zgecon.f \ +dormbr.f \ +zlatrz.f \ +zungqr.f \ +dlabrd.f \ +dlasq4.f \ +dggev.f \ +dpptrf.f \ +zgelq2.f \ +dgeqpf.f \ +dormr3.f \ +dlanhs.f \ +dgerfs.f \ +dlarz.f \ +zgebrd.f \ +zgebd2.f \ +dgebak.f \ +dormrz.f \ +dbdsqr.f \ +dspev.f \ +dlaqp2.f \ +zung2r.f \ +dlange.f \ +zgeqrf.f \ +dormql.f \ +zgesvd.f \ +dladiv.f \ +dlas2.f \ +dgeequ.f \ +dsytf2.f \ +dlahqr.f \ +zlatrs.f \ +zheev.f \ +ztgex2.f \ +zlaic1.f \ +ztrsen.f \ +zlacgv.f \ +dgees.f \ +dlassq.f \ +zlascl.f \ +dtrexc.f \ +dlasq5.f \ +dormhr.f \ +zgesc2.f \ +dlatdf.f \ +dsycon.f \ +dlarfg.f \ +dorm2l.f \ +dsptrf.f \ +zungbr.f \ +dgesv.f \ +dgetrf.f \ +zhseqr.f \ +dtgsy2.f \ +dlaev2.f \ +dgebal.f \ +zlarfb.f \ +zlahrd.f \ +dlantr.f \ +zgghrd.f \ +dlatzm.f \ +ztgsyl.f \ +ztrtri.f \ +zlatrd.f \ +zlacpy.f \ +zgetri.f \ +dlasr.f \ +zgeqp3.f \ +zungql.f \ +dlanst.f \ +zlarzt.f \ +dorglq.f \ +dorgl2.f \ +dlasq6.f \ +dlasy2.f \ +dopgtr.f \ +dgeqlf.f \ +dgetf2.f \ +dtgevc.f \ +zunghr.f \ +dlarzb.f \ +dlarfx.f \ +zung2l.f \ +zggev.f \ +dzsum1.f \ +dlaqps.f \ +dtrcon.f \ +dlasrt.f \ +dsyev.f \ +dorgqr.f \ +dgecon.f \ +dlatrz.f \ +zlarz.f \ +ztgexc.f \ +zggbak.f \ +ztzrzf.f \ +dpotrs.f \ +dsytri.f \ +dgelq2.f \ +zpotrf.f \ +dgebrd.f \ +dgebd2.f \ +zgetc2.f \ +dorgrq.f \ +dorg2r.f \ +dorgr2.f \ +zhgeqz.f \ +dgeqrf.f \ +dlaln2.f \ +dgesvd.f \ +ztrevc.f \ +zgelsy.f \ +zgees.f \ +zlaswp.f \ +dspgv.f \ +dlanv2.f \ +zunmlq.f \ +dlae2.f \ +zunml2.f \ +dlatrs.f \ +dtgex2.f \ +dlaic1.f \ +dgels.f \ +dtrsen.f \ +zdrscl.f \ +zlarft.f \ +dlascl.f \ +zlartg.f \ +zggbal.f \ +dgesc2.f \ +dgerqf.f \ +zgeqr2.f \ +zgetrs.f \ +ilaenv.f \ +dorgbr.f \ +zpotf2.f \ +dhseqr.f \ +dlarf.f \ +dgegs.f \ +dgeev.f \ +dlarfb.f \ +zlasr.f \ +dlapy2.f \ +zunmqr.f \ +ztrti2.f \ +dlahrd.f \ +dgghrd.f \ +zlaset.f \ +dtgsyl.f \ +dtrtri.f \ +dlatrd.f \ +dlacpy.f \ +dgetri.f \ +zgehrd.f \ +zgehd2.f \ +dgeqp3.f \ +dorgql.f \ +zungtr.f \ +zunm2r.f \ +dlarzt.f \ +dlapmt.f \ +ieeeck.f \ +dlasq1.f \ +dorghr.f \ +zlacon.f \ +dgelsx.f \ +dsterf.f \ +zsteqr.f \ +zgelqf.f \ +dsytrs.f \ +dgges.f \ +dorg2l.f \ +dlapy3.f \ +lsame.f \ +ztrsyl.f \ +izmax1.f \ +ztgsen.f \ +zunmbr.f \ +zlabrd.f \ +dtgexc.f \ +dgeql2.f \ +dlagv2.f \ +dggbak.f \ +dtzrzf.f \ +zlaqr0.f \ +dlacn2.f \ +zlacn2.f \ +dlazq3.f \ +zlahr2.f \ +dlaqr0.f \ +iparmq.f \ +disnan.f \ +dlaisnan.f \ +dlahr2.f \ +zlaqr3.f \ +zlaqr4.f \ +zlaqr5.f \ +dlazq4.f \ +dlaqr3.f \ +dlaqr4.f \ +dlaqr5.f \ +zlaqr2.f \ +zlaqr1.f \ +dlaqr2.f \ +dlaqr1.f + +HEAD = $(top_builddir)/includes/lapack.h + +libscilapack_la_SOURCES = $(HEAD) $(LAPACK_FORTRAN_SOURCES) + +libdummy_lapack_la_SOURCES = dlamch.f slamch.f + +libdummy_lapack_la_FFLAGS = `echo "@FFLAGS@"| sed -e 's|-O[0-9+]|-O0|'` + + +libscilapack_la_LIBADD = libdummy-lapack.la \ + $(top_builddir)/src/fortran/blas/libsciblas.la + +libscilapack_la_PKGCONFIG = lapack.pc + +libdummy_lapack_la-dlamch.lo: dlamch.f + $(LIBTOOL) --tag=F77 --mode=compile $(F77) $(libdummy_lapack_la_FFLAGS) -c -o libdummy_lapack_la-dlamch.lo `test -f 'dlamch.f' || echo '$(srcdir)/'`dlamch.f + +libdummy_lapack_la-slamch.lo: slamch.f + $(LIBTOOL) --tag=F77 --mode=compile $(F77) $(libdummy_lapack_la_FFLAGS) -c -o libdummy_lapack_la-slamch.lo `test -f 'slamch.f' || echo '$(srcdir)/'`slamch.f diff --git a/2.3-1/src/fortran/lapack/Makefile.in b/2.3-1/src/fortran/lapack/Makefile.in new file mode 100644 index 00000000..3936d9ae --- /dev/null +++ b/2.3-1/src/fortran/lapack/Makefile.in @@ -0,0 +1,894 @@ +# Makefile.in generated by automake 1.11.1 from Makefile.am. +# @configure_input@ + +# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, +# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, +# Inc. +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. + +@SET_MAKE@ + +########## +### Sylvestre Ledru +### INRIA - Scilab 2006 +########## + +VPATH = @srcdir@ +pkgdatadir = $(datadir)/@PACKAGE@ +pkgincludedir = $(includedir)/@PACKAGE@ +pkglibdir = $(libdir)/@PACKAGE@ +pkglibexecdir = $(libexecdir)/@PACKAGE@ +am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd +install_sh_DATA = $(install_sh) -c -m 644 +install_sh_PROGRAM = $(install_sh) -c +install_sh_SCRIPT = $(install_sh) -c +INSTALL_HEADER = $(INSTALL_DATA) +transform = $(program_transform_name) +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : +build_triplet = @build@ +host_triplet = @host@ +subdir = src/fortran/lapack +DIST_COMMON = README $(srcdir)/Makefile.am $(srcdir)/Makefile.in +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +am__aclocal_m4_deps = $(top_srcdir)/configure.ac +am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ + $(ACLOCAL_M4) +mkinstalldirs = $(install_sh) -d +CONFIG_HEADER = $(top_builddir)/includes/machine.h +CONFIG_CLEAN_FILES = +CONFIG_CLEAN_VPATH_FILES = +am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; +am__vpath_adj = case $$p in \ + $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ + *) f=$$p;; \ + esac; +am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; +am__install_max = 40 +am__nobase_strip_setup = \ + srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` +am__nobase_strip = \ + for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" +am__nobase_list = $(am__nobase_strip_setup); \ + for p in $$list; do echo "$$p $$p"; done | \ + sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ + $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ + if (++n[$$2] == $(am__install_max)) \ + { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ + END { for (dir in files) print dir, files[dir] }' +am__base_list = \ + sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ + sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' +am__installdirs = "$(DESTDIR)$(pkglibdir)" +LTLIBRARIES = $(noinst_LTLIBRARIES) $(pkglib_LTLIBRARIES) +libdummy_lapack_la_LIBADD = +am_libdummy_lapack_la_OBJECTS = libdummy_lapack_la-dlamch.lo \ + libdummy_lapack_la-slamch.lo +libdummy_lapack_la_OBJECTS = $(am_libdummy_lapack_la_OBJECTS) +libdummy_lapack_la_LINK = $(LIBTOOL) --tag=F77 $(AM_LIBTOOLFLAGS) \ + $(LIBTOOLFLAGS) --mode=link $(F77LD) \ + $(libdummy_lapack_la_FFLAGS) $(FFLAGS) $(AM_LDFLAGS) \ + $(LDFLAGS) -o $@ +libscilapack_la_DEPENDENCIES = libdummy-lapack.la \ + $(top_builddir)/src/fortran/blas/libsciblas.la +am__objects_1 = +am__objects_2 = dlasv2.lo zgeqpf.lo zrot.lo dpotrf.lo zunmr3.lo \ + zlanhs.lo zgebak.lo zbdsqr.lo zunmrz.lo dgetc2.lo zlaqp2.lo \ + dsytrd.lo dsytd2.lo zlange.lo dlansp.lo dhgeqz.lo dlasq2.lo \ + dtrevc.lo dgelsy.lo zladiv.lo dlaswp.lo dormlq.lo dorml2.lo \ + dlaexc.lo zlahqr.lo zdrot.lo dlabad.lo dlarft.lo zlassq.lo \ + dlartg.lo zlarf.lo ztrexc.lo zgeev.lo dggbal.lo dtrtrs.lo \ + zlatdf.lo dgeqr2.lo zlarfg.lo dgetrs.lo dlag2.lo dlaqge.lo \ + dpotf2.lo zgetrf.lo ztgsy2.lo zgebal.lo dspgst.lo dormqr.lo \ + drscl.lo dtrti2.lo dlaset.lo dgeesx.lo dpocon.lo dlasyf.lo \ + dgerq2.lo dlasq3.lo dlansy.lo dgehrd.lo dgehd2.lo dsptrd.lo \ + dorgtr.lo dormrq.lo dorm2r.lo dormr2.lo zgges.lo zunglq.lo \ + zlanhe.lo zungl2.lo zhetrd.lo zhetd2.lo dlacon.lo dgesvx.lo \ + zgetf2.lo ztgevc.lo dsteqr.lo dgelqf.lo zlarzb.lo zlarfx.lo \ + dsysv.lo zlaqps.lo dtzrqf.lo dsytrf.lo xerbla.lo dtrsyl.lo \ + dgelss.lo dtgsen.lo zgecon.lo dormbr.lo zlatrz.lo zungqr.lo \ + dlabrd.lo dlasq4.lo dggev.lo dpptrf.lo zgelq2.lo dgeqpf.lo \ + dormr3.lo dlanhs.lo dgerfs.lo dlarz.lo zgebrd.lo zgebd2.lo \ + dgebak.lo dormrz.lo dbdsqr.lo dspev.lo dlaqp2.lo zung2r.lo \ + dlange.lo zgeqrf.lo dormql.lo zgesvd.lo dladiv.lo dlas2.lo \ + dgeequ.lo dsytf2.lo dlahqr.lo zlatrs.lo zheev.lo ztgex2.lo \ + zlaic1.lo ztrsen.lo zlacgv.lo dgees.lo dlassq.lo zlascl.lo \ + dtrexc.lo dlasq5.lo dormhr.lo zgesc2.lo dlatdf.lo dsycon.lo \ + dlarfg.lo dorm2l.lo dsptrf.lo zungbr.lo dgesv.lo dgetrf.lo \ + zhseqr.lo dtgsy2.lo dlaev2.lo dgebal.lo zlarfb.lo zlahrd.lo \ + dlantr.lo zgghrd.lo dlatzm.lo ztgsyl.lo ztrtri.lo zlatrd.lo \ + zlacpy.lo zgetri.lo dlasr.lo zgeqp3.lo zungql.lo dlanst.lo \ + zlarzt.lo dorglq.lo dorgl2.lo dlasq6.lo dlasy2.lo dopgtr.lo \ + dgeqlf.lo dgetf2.lo dtgevc.lo zunghr.lo dlarzb.lo dlarfx.lo \ + zung2l.lo zggev.lo dzsum1.lo dlaqps.lo dtrcon.lo dlasrt.lo \ + dsyev.lo dorgqr.lo dgecon.lo dlatrz.lo zlarz.lo ztgexc.lo \ + zggbak.lo ztzrzf.lo dpotrs.lo dsytri.lo dgelq2.lo zpotrf.lo \ + dgebrd.lo dgebd2.lo zgetc2.lo dorgrq.lo dorg2r.lo dorgr2.lo \ + zhgeqz.lo dgeqrf.lo dlaln2.lo dgesvd.lo ztrevc.lo zgelsy.lo \ + zgees.lo zlaswp.lo dspgv.lo dlanv2.lo zunmlq.lo dlae2.lo \ + zunml2.lo dlatrs.lo dtgex2.lo dlaic1.lo dgels.lo dtrsen.lo \ + zdrscl.lo zlarft.lo dlascl.lo zlartg.lo zggbal.lo dgesc2.lo \ + dgerqf.lo zgeqr2.lo zgetrs.lo ilaenv.lo dorgbr.lo zpotf2.lo \ + dhseqr.lo dlarf.lo dgegs.lo dgeev.lo dlarfb.lo zlasr.lo \ + dlapy2.lo zunmqr.lo ztrti2.lo dlahrd.lo dgghrd.lo zlaset.lo \ + dtgsyl.lo dtrtri.lo dlatrd.lo dlacpy.lo dgetri.lo zgehrd.lo \ + zgehd2.lo dgeqp3.lo dorgql.lo zungtr.lo zunm2r.lo dlarzt.lo \ + dlapmt.lo ieeeck.lo dlasq1.lo dorghr.lo zlacon.lo dgelsx.lo \ + dsterf.lo zsteqr.lo zgelqf.lo dsytrs.lo dgges.lo dorg2l.lo \ + dlapy3.lo lsame.lo ztrsyl.lo izmax1.lo ztgsen.lo zunmbr.lo \ + zlabrd.lo dtgexc.lo dgeql2.lo dlagv2.lo dggbak.lo dtzrzf.lo \ + zlaqr0.lo dlacn2.lo zlacn2.lo dlazq3.lo zlahr2.lo dlaqr0.lo \ + iparmq.lo disnan.lo dlaisnan.lo dlahr2.lo zlaqr3.lo zlaqr4.lo \ + zlaqr5.lo dlazq4.lo dlaqr3.lo dlaqr4.lo dlaqr5.lo zlaqr2.lo \ + zlaqr1.lo dlaqr2.lo dlaqr1.lo +am_libscilapack_la_OBJECTS = $(am__objects_1) $(am__objects_2) +libscilapack_la_OBJECTS = $(am_libscilapack_la_OBJECTS) +DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir)/includes +F77COMPILE = $(F77) $(AM_FFLAGS) $(FFLAGS) +LTF77COMPILE = $(LIBTOOL) --tag=F77 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \ + --mode=compile $(F77) $(AM_FFLAGS) $(FFLAGS) +F77LD = $(F77) +F77LINK = $(LIBTOOL) --tag=F77 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \ + --mode=link $(F77LD) $(AM_FFLAGS) $(FFLAGS) $(AM_LDFLAGS) \ + $(LDFLAGS) -o $@ +COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ + $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) +LTCOMPILE = $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \ + --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) \ + $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) +CCLD = $(CC) +LINK = $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \ + --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) $(AM_LDFLAGS) \ + $(LDFLAGS) -o $@ +SOURCES = $(libdummy_lapack_la_SOURCES) $(libscilapack_la_SOURCES) +DIST_SOURCES = $(libdummy_lapack_la_SOURCES) \ + $(libscilapack_la_SOURCES) +ETAGS = etags +CTAGS = ctags +DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) +ACLOCAL = @ACLOCAL@ +AMTAR = @AMTAR@ +AR = @AR@ +AUTOCONF = @AUTOCONF@ +AUTOHEADER = @AUTOHEADER@ +AUTOMAKE = @AUTOMAKE@ +AWK = @AWK@ +CC = @CC@ +CCDEPMODE = @CCDEPMODE@ +CFLAGS = @CFLAGS@ +CPP = @CPP@ +CPPFLAGS = @CPPFLAGS@ +CXX = @CXX@ +CXXCPP = @CXXCPP@ +CXXDEPMODE = @CXXDEPMODE@ +CXXFLAGS = @CXXFLAGS@ +CYGPATH_W = @CYGPATH_W@ +DEFS = @DEFS@ +DEPDIR = @DEPDIR@ +DSYMUTIL = @DSYMUTIL@ +DUMPBIN = @DUMPBIN@ +ECHO_C = @ECHO_C@ +ECHO_N = @ECHO_N@ +ECHO_T = @ECHO_T@ +EGREP = @EGREP@ +EXEEXT = @EXEEXT@ +F77 = @F77@ +FFLAGS = @FFLAGS@ +FGREP = @FGREP@ +GREP = @GREP@ +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ +LD = @LD@ +LDFLAGS = @LDFLAGS@ +LIBMATH = @LIBMATH@ +LIBOBJS = @LIBOBJS@ +LIBS = @LIBS@ +LIBTOOL = @LIBTOOL@ +LIPO = @LIPO@ +LN_S = @LN_S@ +LTLIBOBJS = @LTLIBOBJS@ +MAINT = @MAINT@ +MAKEINFO = @MAKEINFO@ +MKDIR_P = @MKDIR_P@ +NM = @NM@ +NMEDIT = @NMEDIT@ +OBJDUMP = @OBJDUMP@ +OBJEXT = @OBJEXT@ +OTOOL = @OTOOL@ +OTOOL64 = @OTOOL64@ +PACKAGE = @PACKAGE@ +PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ +PACKAGE_NAME = @PACKAGE_NAME@ +PACKAGE_STRING = @PACKAGE_STRING@ +PACKAGE_TARNAME = @PACKAGE_TARNAME@ +PACKAGE_URL = @PACKAGE_URL@ +PACKAGE_VERSION = @PACKAGE_VERSION@ +PATH_SEPARATOR = @PATH_SEPARATOR@ +RANLIB = @RANLIB@ +SED = @SED@ +SET_MAKE = @SET_MAKE@ +SHELL = @SHELL@ +STRIP = @STRIP@ +VERSION = @VERSION@ +abs_builddir = @abs_builddir@ +abs_srcdir = @abs_srcdir@ +abs_top_builddir = @abs_top_builddir@ +abs_top_srcdir = @abs_top_srcdir@ +ac_ct_CC = @ac_ct_CC@ +ac_ct_CXX = @ac_ct_CXX@ +ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ +ac_ct_F77 = @ac_ct_F77@ +am__include = @am__include@ +am__leading_dot = @am__leading_dot@ +am__quote = @am__quote@ +am__tar = @am__tar@ +am__untar = @am__untar@ +bindir = @bindir@ +build = @build@ +build_alias = @build_alias@ +build_cpu = @build_cpu@ +build_os = @build_os@ +build_vendor = @build_vendor@ +builddir = @builddir@ +datadir = @datadir@ +datarootdir = @datarootdir@ +docdir = @docdir@ +dvidir = @dvidir@ +exec_prefix = @exec_prefix@ +host = @host@ +host_alias = @host_alias@ +host_cpu = @host_cpu@ +host_os = @host_os@ +host_vendor = @host_vendor@ +htmldir = @htmldir@ +includedir = @includedir@ +infodir = @infodir@ +install_sh = @install_sh@ +libdir = @libdir@ +libexecdir = @libexecdir@ +localedir = @localedir@ +localstatedir = @localstatedir@ +lt_ECHO = @lt_ECHO@ +mandir = @mandir@ +mkdir_p = @mkdir_p@ +oldincludedir = @oldincludedir@ +pdfdir = @pdfdir@ +prefix = @prefix@ +program_transform_name = @program_transform_name@ +psdir = @psdir@ +sbindir = @sbindir@ +sharedstatedir = @sharedstatedir@ +srcdir = @srcdir@ +sysconfdir = @sysconfdir@ +target_alias = @target_alias@ +top_build_prefix = @top_build_prefix@ +top_builddir = @top_builddir@ +top_srcdir = @top_srcdir@ + +#### Target ###### +modulename = lapack +pkglib_LTLIBRARIES = libscilapack.la +noinst_LTLIBRARIES = libdummy-lapack.la +LAPACK_FORTRAN_SOURCES = dlasv2.f \ +zgeqpf.f \ +zrot.f \ +dpotrf.f \ +zunmr3.f \ +zlanhs.f \ +zgebak.f \ +zbdsqr.f \ +zunmrz.f \ +dgetc2.f \ +zlaqp2.f \ +dsytrd.f \ +dsytd2.f \ +zlange.f \ +dlansp.f \ +dhgeqz.f \ +dlasq2.f \ +dtrevc.f \ +dgelsy.f \ +zladiv.f \ +dlaswp.f \ +dormlq.f \ +dorml2.f \ +dlaexc.f \ +zlahqr.f \ +zdrot.f \ +dlabad.f \ +dlarft.f \ +zlassq.f \ +dlartg.f \ +zlarf.f \ +ztrexc.f \ +zgeev.f \ +dggbal.f \ +dtrtrs.f \ +zlatdf.f \ +dgeqr2.f \ +zlarfg.f \ +dgetrs.f \ +dlag2.f \ +dlaqge.f \ +dpotf2.f \ +zgetrf.f \ +ztgsy2.f \ +zgebal.f \ +dspgst.f \ +dormqr.f \ +drscl.f \ +dtrti2.f \ +dlaset.f \ +dgeesx.f \ +dpocon.f \ +dlasyf.f \ +dgerq2.f \ +dlasq3.f \ +dlansy.f \ +dgehrd.f \ +dgehd2.f \ +dsptrd.f \ +dorgtr.f \ +dormrq.f \ +dorm2r.f \ +dormr2.f \ +zgges.f \ +zunglq.f \ +zlanhe.f \ +zungl2.f \ +zhetrd.f \ +zhetd2.f \ +dlacon.f \ +dgesvx.f \ +zgetf2.f \ +ztgevc.f \ +dsteqr.f \ +dgelqf.f \ +zlarzb.f \ +zlarfx.f \ +dsysv.f \ +zlaqps.f \ +dtzrqf.f \ +dsytrf.f \ +xerbla.f \ +dtrsyl.f \ +dgelss.f \ +dtgsen.f \ +zgecon.f \ +dormbr.f \ +zlatrz.f \ +zungqr.f \ +dlabrd.f \ +dlasq4.f \ +dggev.f \ +dpptrf.f \ +zgelq2.f \ +dgeqpf.f \ +dormr3.f \ +dlanhs.f \ +dgerfs.f \ +dlarz.f \ +zgebrd.f \ +zgebd2.f \ +dgebak.f \ +dormrz.f \ +dbdsqr.f \ +dspev.f \ +dlaqp2.f \ +zung2r.f \ +dlange.f \ +zgeqrf.f \ +dormql.f \ +zgesvd.f \ +dladiv.f \ +dlas2.f \ +dgeequ.f \ +dsytf2.f \ +dlahqr.f \ +zlatrs.f \ +zheev.f \ +ztgex2.f \ +zlaic1.f \ +ztrsen.f \ +zlacgv.f \ +dgees.f \ +dlassq.f \ +zlascl.f \ +dtrexc.f \ +dlasq5.f \ +dormhr.f \ +zgesc2.f \ +dlatdf.f \ +dsycon.f \ +dlarfg.f \ +dorm2l.f \ +dsptrf.f \ +zungbr.f \ +dgesv.f \ +dgetrf.f \ +zhseqr.f \ +dtgsy2.f \ +dlaev2.f \ +dgebal.f \ +zlarfb.f \ +zlahrd.f \ +dlantr.f \ +zgghrd.f \ +dlatzm.f \ +ztgsyl.f \ +ztrtri.f \ +zlatrd.f \ +zlacpy.f \ +zgetri.f \ +dlasr.f \ +zgeqp3.f \ +zungql.f \ +dlanst.f \ +zlarzt.f \ +dorglq.f \ +dorgl2.f \ +dlasq6.f \ +dlasy2.f \ +dopgtr.f \ +dgeqlf.f \ +dgetf2.f \ +dtgevc.f \ +zunghr.f \ +dlarzb.f \ +dlarfx.f \ +zung2l.f \ +zggev.f \ +dzsum1.f \ +dlaqps.f \ +dtrcon.f \ +dlasrt.f \ +dsyev.f \ +dorgqr.f \ +dgecon.f \ +dlatrz.f \ +zlarz.f \ +ztgexc.f \ +zggbak.f \ +ztzrzf.f \ +dpotrs.f \ +dsytri.f \ +dgelq2.f \ +zpotrf.f \ +dgebrd.f \ +dgebd2.f \ +zgetc2.f \ +dorgrq.f \ +dorg2r.f \ +dorgr2.f \ +zhgeqz.f \ +dgeqrf.f \ +dlaln2.f \ +dgesvd.f \ +ztrevc.f \ +zgelsy.f \ +zgees.f \ +zlaswp.f \ +dspgv.f \ +dlanv2.f \ +zunmlq.f \ +dlae2.f \ +zunml2.f \ +dlatrs.f \ +dtgex2.f \ +dlaic1.f \ +dgels.f \ +dtrsen.f \ +zdrscl.f \ +zlarft.f \ +dlascl.f \ +zlartg.f \ +zggbal.f \ +dgesc2.f \ +dgerqf.f \ +zgeqr2.f \ +zgetrs.f \ +ilaenv.f \ +dorgbr.f \ +zpotf2.f \ +dhseqr.f \ +dlarf.f \ +dgegs.f \ +dgeev.f \ +dlarfb.f \ +zlasr.f \ +dlapy2.f \ +zunmqr.f \ +ztrti2.f \ +dlahrd.f \ +dgghrd.f \ +zlaset.f \ +dtgsyl.f \ +dtrtri.f \ +dlatrd.f \ +dlacpy.f \ +dgetri.f \ +zgehrd.f \ +zgehd2.f \ +dgeqp3.f \ +dorgql.f \ +zungtr.f \ +zunm2r.f \ +dlarzt.f \ +dlapmt.f \ +ieeeck.f \ +dlasq1.f \ +dorghr.f \ +zlacon.f \ +dgelsx.f \ +dsterf.f \ +zsteqr.f \ +zgelqf.f \ +dsytrs.f \ +dgges.f \ +dorg2l.f \ +dlapy3.f \ +lsame.f \ +ztrsyl.f \ +izmax1.f \ +ztgsen.f \ +zunmbr.f \ +zlabrd.f \ +dtgexc.f \ +dgeql2.f \ +dlagv2.f \ +dggbak.f \ +dtzrzf.f \ +zlaqr0.f \ +dlacn2.f \ +zlacn2.f \ +dlazq3.f \ +zlahr2.f \ +dlaqr0.f \ +iparmq.f \ +disnan.f \ +dlaisnan.f \ +dlahr2.f \ +zlaqr3.f \ +zlaqr4.f \ +zlaqr5.f \ +dlazq4.f \ +dlaqr3.f \ +dlaqr4.f \ +dlaqr5.f \ +zlaqr2.f \ +zlaqr1.f \ +dlaqr2.f \ +dlaqr1.f + +HEAD = $(top_builddir)/includes/lapack.h +libscilapack_la_SOURCES = $(HEAD) $(LAPACK_FORTRAN_SOURCES) +libdummy_lapack_la_SOURCES = dlamch.f slamch.f +libdummy_lapack_la_FFLAGS = `echo "@FFLAGS@"| sed -e 's|-O[0-9+]|-O0|'` +libscilapack_la_LIBADD = libdummy-lapack.la \ + $(top_builddir)/src/fortran/blas/libsciblas.la + +libscilapack_la_PKGCONFIG = lapack.pc +all: all-am + +.SUFFIXES: +.SUFFIXES: .f .lo .o .obj +$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) + @for dep in $?; do \ + case '$(am__configure_deps)' in \ + *$$dep*) \ + ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ + && { if test -f $@; then exit 0; else break; fi; }; \ + exit 1;; \ + esac; \ + done; \ + echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign src/fortran/lapack/Makefile'; \ + $(am__cd) $(top_srcdir) && \ + $(AUTOMAKE) --foreign src/fortran/lapack/Makefile +.PRECIOUS: Makefile +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + @case '$?' in \ + *config.status*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ + *) \ + echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ + esac; + +$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh + +$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(am__aclocal_m4_deps): + +clean-noinstLTLIBRARIES: + -test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES) + @list='$(noinst_LTLIBRARIES)'; for p in $$list; do \ + dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \ + test "$$dir" != "$$p" || dir=.; \ + echo "rm -f \"$${dir}/so_locations\""; \ + rm -f "$${dir}/so_locations"; \ + done +install-pkglibLTLIBRARIES: $(pkglib_LTLIBRARIES) + @$(NORMAL_INSTALL) + test -z "$(pkglibdir)" || $(MKDIR_P) "$(DESTDIR)$(pkglibdir)" + @list='$(pkglib_LTLIBRARIES)'; test -n "$(pkglibdir)" || list=; \ + list2=; for p in $$list; do \ + if test -f $$p; then \ + list2="$$list2 $$p"; \ + else :; fi; \ + done; \ + test -z "$$list2" || { \ + echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 '$(DESTDIR)$(pkglibdir)'"; \ + $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 "$(DESTDIR)$(pkglibdir)"; \ + } + +uninstall-pkglibLTLIBRARIES: + @$(NORMAL_UNINSTALL) + @list='$(pkglib_LTLIBRARIES)'; test -n "$(pkglibdir)" || list=; \ + for p in $$list; do \ + $(am__strip_dir) \ + echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f '$(DESTDIR)$(pkglibdir)/$$f'"; \ + $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f "$(DESTDIR)$(pkglibdir)/$$f"; \ + done + +clean-pkglibLTLIBRARIES: + -test -z "$(pkglib_LTLIBRARIES)" || rm -f $(pkglib_LTLIBRARIES) + @list='$(pkglib_LTLIBRARIES)'; for p in $$list; do \ + dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \ + test "$$dir" != "$$p" || dir=.; \ + echo "rm -f \"$${dir}/so_locations\""; \ + rm -f "$${dir}/so_locations"; \ + done +libdummy-lapack.la: $(libdummy_lapack_la_OBJECTS) $(libdummy_lapack_la_DEPENDENCIES) + $(libdummy_lapack_la_LINK) $(libdummy_lapack_la_OBJECTS) $(libdummy_lapack_la_LIBADD) $(LIBS) +libscilapack.la: $(libscilapack_la_OBJECTS) $(libscilapack_la_DEPENDENCIES) + $(F77LINK) -rpath $(pkglibdir) $(libscilapack_la_OBJECTS) $(libscilapack_la_LIBADD) $(LIBS) + +mostlyclean-compile: + -rm -f *.$(OBJEXT) + +distclean-compile: + -rm -f *.tab.c + +.f.o: + $(F77COMPILE) -c -o $@ $< + +.f.obj: + $(F77COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` + +.f.lo: + $(LTF77COMPILE) -c -o $@ $< + +mostlyclean-libtool: + -rm -f *.lo + +clean-libtool: + -rm -rf .libs _libs + +ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES) + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ + END { if (nonempty) { for (i in files) print i; }; }'`; \ + mkid -fID $$unique +tags: TAGS + +TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ + $(TAGS_FILES) $(LISP) + set x; \ + here=`pwd`; \ + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ + END { if (nonempty) { for (i in files) print i; }; }'`; \ + shift; \ + if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ + test -n "$$unique" || unique=$$empty_fix; \ + if test $$# -gt 0; then \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + "$$@" $$unique; \ + else \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + $$unique; \ + fi; \ + fi +ctags: CTAGS +CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ + $(TAGS_FILES) $(LISP) + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ + END { if (nonempty) { for (i in files) print i; }; }'`; \ + test -z "$(CTAGS_ARGS)$$unique" \ + || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ + $$unique + +GTAGS: + here=`$(am__cd) $(top_builddir) && pwd` \ + && $(am__cd) $(top_srcdir) \ + && gtags -i $(GTAGS_ARGS) "$$here" + +distclean-tags: + -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags + +distdir: $(DISTFILES) + @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + list='$(DISTFILES)'; \ + dist_files=`for file in $$list; do echo $$file; done | \ + sed -e "s|^$$srcdirstrip/||;t" \ + -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ + case $$dist_files in \ + */*) $(MKDIR_P) `echo "$$dist_files" | \ + sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ + sort -u` ;; \ + esac; \ + for file in $$dist_files; do \ + if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ + if test -d $$d/$$file; then \ + dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ + if test -d "$(distdir)/$$file"; then \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ + cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ + else \ + test -f "$(distdir)/$$file" \ + || cp -p $$d/$$file "$(distdir)/$$file" \ + || exit 1; \ + fi; \ + done +check-am: all-am +check: check-am +all-am: Makefile $(LTLIBRARIES) +installdirs: + for dir in "$(DESTDIR)$(pkglibdir)"; do \ + test -z "$$dir" || $(MKDIR_P) "$$dir"; \ + done +install: install-am +install-exec: install-exec-am +install-data: install-data-am +uninstall: uninstall-am + +install-am: all-am + @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am + +installcheck: installcheck-am +install-strip: + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + `test -z '$(STRIP)' || \ + echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install +mostlyclean-generic: + +clean-generic: + +distclean-generic: + -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) + -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) + +maintainer-clean-generic: + @echo "This command is intended for maintainers to use" + @echo "it deletes files that may require special tools to rebuild." +clean: clean-am + +clean-am: clean-generic clean-libtool clean-noinstLTLIBRARIES \ + clean-pkglibLTLIBRARIES mostlyclean-am + +distclean: distclean-am + -rm -f Makefile +distclean-am: clean-am distclean-compile distclean-generic \ + distclean-tags + +dvi: dvi-am + +dvi-am: + +html: html-am + +html-am: + +info: info-am + +info-am: + +install-data-am: + +install-dvi: install-dvi-am + +install-dvi-am: + +install-exec-am: install-pkglibLTLIBRARIES + +install-html: install-html-am + +install-html-am: + +install-info: install-info-am + +install-info-am: + +install-man: + +install-pdf: install-pdf-am + +install-pdf-am: + +install-ps: install-ps-am + +install-ps-am: + +installcheck-am: + +maintainer-clean: maintainer-clean-am + -rm -f Makefile +maintainer-clean-am: distclean-am maintainer-clean-generic + +mostlyclean: mostlyclean-am + +mostlyclean-am: mostlyclean-compile mostlyclean-generic \ + mostlyclean-libtool + +pdf: pdf-am + +pdf-am: + +ps: ps-am + +ps-am: + +uninstall-am: uninstall-pkglibLTLIBRARIES + +.MAKE: install-am install-strip + +.PHONY: CTAGS GTAGS all all-am check check-am clean clean-generic \ + clean-libtool clean-noinstLTLIBRARIES clean-pkglibLTLIBRARIES \ + ctags distclean distclean-compile distclean-generic \ + distclean-libtool distclean-tags distdir dvi dvi-am html \ + html-am info info-am install install-am install-data \ + install-data-am install-dvi install-dvi-am install-exec \ + install-exec-am install-html install-html-am install-info \ + install-info-am install-man install-pdf install-pdf-am \ + install-pkglibLTLIBRARIES install-ps install-ps-am \ + install-strip installcheck installcheck-am installdirs \ + maintainer-clean maintainer-clean-generic mostlyclean \ + mostlyclean-compile mostlyclean-generic mostlyclean-libtool \ + pdf pdf-am ps ps-am tags uninstall uninstall-am \ + uninstall-pkglibLTLIBRARIES + + +libdummy_lapack_la-dlamch.lo: dlamch.f + $(LIBTOOL) --tag=F77 --mode=compile $(F77) $(libdummy_lapack_la_FFLAGS) -c -o libdummy_lapack_la-dlamch.lo `test -f 'dlamch.f' || echo '$(srcdir)/'`dlamch.f + +libdummy_lapack_la-slamch.lo: slamch.f + $(LIBTOOL) --tag=F77 --mode=compile $(F77) $(libdummy_lapack_la_FFLAGS) -c -o libdummy_lapack_la-slamch.lo `test -f 'slamch.f' || echo '$(srcdir)/'`slamch.f + +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/2.3-1/src/fortran/lapack/README b/2.3-1/src/fortran/lapack/README new file mode 100644 index 00000000..c14fb64f --- /dev/null +++ b/2.3-1/src/fortran/lapack/README @@ -0,0 +1,5 @@ +This directory contains LAPACK routines. +File xerbla.f is not used. +A customized version of xerbla +for Scilab is in SCIDIR/system/xerbla.f + diff --git a/2.3-1/src/fortran/lapack/dbdsqr.f b/2.3-1/src/fortran/lapack/dbdsqr.f new file mode 100644 index 00000000..b9f87ec1 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dbdsqr.f @@ -0,0 +1,742 @@ + SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, + $ LDU, C, LDC, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), + $ VT( LDVT, * ), WORK( * ) +* .. +* +* 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 (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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION NEGONE + PARAMETER ( NEGONE = -1.0D0 ) + DOUBLE PRECISION HNDRTH + PARAMETER ( HNDRTH = 0.01D0 ) + DOUBLE PRECISION TEN + PARAMETER ( TEN = 10.0D0 ) + DOUBLE PRECISION HNDRD + PARAMETER ( HNDRD = 100.0D0 ) + DOUBLE PRECISION MEIGTH + PARAMETER ( MEIGTH = -0.125D0 ) + INTEGER MAXITR + PARAMETER ( MAXITR = 6 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, ROTATE + INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1, + $ NM12, NM13, OLDLL, OLDM + DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, + $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, + $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA, + $ SN, THRESH, TOL, TOLMUL, UNFL +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLARTG, DLAS2, DLASQ1, DLASR, DLASV2, DROT, + $ DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NCVT.LT.0 ) THEN + INFO = -3 + ELSE IF( NRU.LT.0 ) THEN + INFO = -4 + ELSE IF( NCC.LT.0 ) THEN + INFO = -5 + ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. + $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN + INFO = -9 + ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN + INFO = -11 + ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. + $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DBDSQR', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN + IF( N.EQ.1 ) + $ GO TO 160 +* +* ROTATE is true if any singular vectors desired, false otherwise +* + ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) +* +* If no singular vectors desired, use qd algorithm +* + IF( .NOT.ROTATE ) THEN + CALL DLASQ1( N, D, E, WORK, INFO ) + RETURN + END IF +* + 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 ) THEN + DO 10 I = 1, N - 1 + CALL 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 + 10 CONTINUE +* +* Update singular vectors if desired +* + IF( NRU.GT.0 ) + $ CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U, + $ LDU ) + IF( NCC.GT.0 ) + $ CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C, + $ LDC ) + END IF +* +* 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)) +* + TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) ) + TOL = TOLMUL*EPS +* +* Compute approximate maximum, minimum singular values +* + SMAX = ZERO + DO 20 I = 1, N + SMAX = MAX( SMAX, ABS( D( I ) ) ) + 20 CONTINUE + DO 30 I = 1, N - 1 + SMAX = MAX( SMAX, ABS( E( I ) ) ) + 30 CONTINUE + SMINL = ZERO + IF( TOL.GE.ZERO ) THEN +* +* Relative accuracy desired +* + SMINOA = ABS( D( 1 ) ) + IF( SMINOA.EQ.ZERO ) + $ GO TO 50 + MU = SMINOA + DO 40 I = 2, N + MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) ) + SMINOA = MIN( SMINOA, MU ) + IF( SMINOA.EQ.ZERO ) + $ GO TO 50 + 40 CONTINUE + 50 CONTINUE + SMINOA = SMINOA / SQRT( DBLE( N ) ) + THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL ) + ELSE +* +* Absolute accuracy desired +* + THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL ) + END IF +* +* 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 = MAXITR*N*N + ITER = 0 + OLDLL = -1 + OLDM = -1 +* +* M points to last element of unconverged part of matrix +* + M = N +* +* Begin main iteration loop +* + 60 CONTINUE +* +* Check for convergence or exceeding iteration count +* + IF( M.LE.1 ) + $ GO TO 160 + IF( ITER.GT.MAXIT ) + $ GO TO 200 +* +* Find diagonal block of matrix to work on +* + IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH ) + $ D( M ) = ZERO + SMAX = ABS( D( M ) ) + SMIN = SMAX + DO 70 LLL = 1, M - 1 + LL = M - LLL + ABSS = ABS( D( LL ) ) + ABSE = ABS( E( LL ) ) + IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH ) + $ D( LL ) = ZERO + IF( ABSE.LE.THRESH ) + $ GO TO 80 + SMIN = MIN( SMIN, ABSS ) + SMAX = MAX( SMAX, ABSS, ABSE ) + 70 CONTINUE + LL = 0 + GO TO 90 + 80 CONTINUE + E( LL ) = ZERO +* +* Matrix splits since E(LL) = 0 +* + IF( LL.EQ.M-1 ) THEN +* +* Convergence of bottom singular value, return to top of loop +* + M = M - 1 + GO TO 60 + END IF + 90 CONTINUE + LL = LL + 1 +* +* E(LL) through E(M-1) are nonzero, E(LL-1) is zero +* + IF( LL.EQ.M-1 ) THEN +* +* 2 by 2 block, handle separately +* + CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR, + $ COSR, SINL, COSL ) + D( M-1 ) = SIGMX + E( M-1 ) = ZERO + D( M ) = SIGMN +* +* Compute singular vectors, if desired +* + IF( NCVT.GT.0 ) + $ CALL DROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR, + $ SINR ) + IF( NRU.GT.0 ) + $ CALL DROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL ) + IF( NCC.GT.0 ) + $ CALL DROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL, + $ SINL ) + M = M - 2 + GO TO 60 + END IF +* +* If working on new submatrix, choose shift direction +* (from larger end diagonal element towards smaller) +* + IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN + IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN +* +* 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 + END IF + END IF +* +* Apply convergence tests +* + IF( IDIR.EQ.1 ) THEN +* +* Run convergence test in forward direction +* First apply standard test to bottom of matrix +* + IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR. + $ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN + E( M-1 ) = ZERO + GO TO 60 + END IF +* + IF( TOL.GE.ZERO ) THEN +* +* If relative accuracy desired, +* apply convergence criterion forward +* + MU = ABS( D( LL ) ) + SMINL = MU + DO 100 LLL = LL, M - 1 + IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN + E( LLL ) = ZERO + GO TO 60 + END IF + MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) + SMINL = MIN( SMINL, MU ) + 100 CONTINUE + END IF +* + ELSE +* +* Run convergence test in backward direction +* First apply standard test to top of matrix +* + IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR. + $ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN + E( LL ) = ZERO + GO TO 60 + END IF +* + IF( TOL.GE.ZERO ) THEN +* +* If relative accuracy desired, +* apply convergence criterion backward +* + MU = ABS( D( M ) ) + SMINL = MU + DO 110 LLL = M - 1, LL, -1 + IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN + E( LLL ) = ZERO + GO TO 60 + END IF + MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) + SMINL = MIN( SMINL, MU ) + 110 CONTINUE + END IF + END IF + OLDLL = LL + OLDM = M +* +* Compute shift. First, test if shifting would ruin relative +* accuracy, and if so set the shift to zero. +* + IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE. + $ MAX( EPS, HNDRTH*TOL ) ) THEN +* +* Use a zero shift to avoid loss of relative accuracy +* + SHIFT = ZERO + ELSE +* +* Compute the shift from 2-by-2 block at end of matrix +* + IF( IDIR.EQ.1 ) THEN + SLL = ABS( D( LL ) ) + CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R ) + ELSE + SLL = ABS( D( M ) ) + CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R ) + END IF +* +* Test if shift negligible, and if so set to zero +* + IF( SLL.GT.ZERO ) THEN + IF( ( SHIFT / SLL )**2.LT.EPS ) + $ SHIFT = ZERO + END IF + END IF +* +* Increment iteration count +* + ITER = ITER + M - LL +* +* If SHIFT = 0, do simplified QR iteration +* + IF( SHIFT.EQ.ZERO ) THEN + IF( IDIR.EQ.1 ) THEN +* +* Chase bulge from top to bottom +* Save cosines and sines for later singular vector updates +* + CS = ONE + OLDCS = ONE + DO 120 I = LL, M - 1 + CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) + IF( I.GT.LL ) + $ E( I-1 ) = OLDSN*R + CALL DLARTG( OLDCS*R, D( I+1 )*SN, 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 + 120 CONTINUE + H = D( M )*CS + D( M ) = H*OLDCS + E( M-1 ) = H*OLDSN +* +* Update singular vectors +* + IF( NCVT.GT.0 ) + $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), + $ WORK( N ), VT( LL, 1 ), LDVT ) + IF( NRU.GT.0 ) + $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), + $ WORK( NM13+1 ), U( 1, LL ), LDU ) + IF( NCC.GT.0 ) + $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), + $ WORK( NM13+1 ), C( LL, 1 ), LDC ) +* +* Test convergence +* + IF( ABS( E( M-1 ) ).LE.THRESH ) + $ E( M-1 ) = ZERO +* + ELSE +* +* Chase bulge from bottom to top +* Save cosines and sines for later singular vector updates +* + CS = ONE + OLDCS = ONE + DO 130 I = M, LL + 1, -1 + CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) + IF( I.LT.M ) + $ E( I ) = OLDSN*R + CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) + WORK( I-LL ) = CS + WORK( I-LL+NM1 ) = -SN + WORK( I-LL+NM12 ) = OLDCS + WORK( I-LL+NM13 ) = -OLDSN + 130 CONTINUE + H = D( LL )*CS + D( LL ) = H*OLDCS + E( LL ) = H*OLDSN +* +* Update singular vectors +* + IF( NCVT.GT.0 ) + $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), + $ WORK( NM13+1 ), VT( LL, 1 ), LDVT ) + IF( NRU.GT.0 ) + $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), + $ WORK( N ), U( 1, LL ), LDU ) + IF( NCC.GT.0 ) + $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), + $ WORK( N ), C( LL, 1 ), LDC ) +* +* Test convergence +* + IF( ABS( E( LL ) ).LE.THRESH ) + $ E( LL ) = ZERO + END IF + ELSE +* +* Use nonzero shift +* + IF( IDIR.EQ.1 ) THEN +* +* Chase bulge from top to bottom +* Save cosines and sines for later singular vector updates +* + F = ( ABS( D( LL ) )-SHIFT )* + $ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) ) + G = E( LL ) + DO 140 I = LL, M - 1 + CALL DLARTG( F, G, COSR, SINR, R ) + IF( I.GT.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 ) + CALL 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.LT.M-1 ) THEN + G = SINL*E( I+1 ) + E( I+1 ) = COSL*E( I+1 ) + END IF + WORK( I-LL+1 ) = COSR + WORK( I-LL+1+NM1 ) = SINR + WORK( I-LL+1+NM12 ) = COSL + WORK( I-LL+1+NM13 ) = SINL + 140 CONTINUE + E( M-1 ) = F +* +* Update singular vectors +* + IF( NCVT.GT.0 ) + $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), + $ WORK( N ), VT( LL, 1 ), LDVT ) + IF( NRU.GT.0 ) + $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), + $ WORK( NM13+1 ), U( 1, LL ), LDU ) + IF( NCC.GT.0 ) + $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), + $ WORK( NM13+1 ), C( LL, 1 ), LDC ) +* +* Test convergence +* + IF( ABS( E( M-1 ) ).LE.THRESH ) + $ E( M-1 ) = ZERO +* + ELSE +* +* Chase bulge from bottom to top +* Save cosines and sines for later singular vector updates +* + F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT / + $ D( M ) ) + G = E( M-1 ) + DO 150 I = M, LL + 1, -1 + CALL DLARTG( F, G, COSR, SINR, R ) + IF( I.LT.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 ) + CALL 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.GT.LL+1 ) THEN + G = SINL*E( I-2 ) + E( I-2 ) = COSL*E( I-2 ) + END IF + WORK( I-LL ) = COSR + WORK( I-LL+NM1 ) = -SINR + WORK( I-LL+NM12 ) = COSL + WORK( I-LL+NM13 ) = -SINL + 150 CONTINUE + E( LL ) = F +* +* Test convergence +* + IF( ABS( E( LL ) ).LE.THRESH ) + $ E( LL ) = ZERO +* +* Update singular vectors if desired +* + IF( NCVT.GT.0 ) + $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), + $ WORK( NM13+1 ), VT( LL, 1 ), LDVT ) + IF( NRU.GT.0 ) + $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), + $ WORK( N ), U( 1, LL ), LDU ) + IF( NCC.GT.0 ) + $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), + $ WORK( N ), C( LL, 1 ), LDC ) + END IF + END IF +* +* QR iteration finished, go back and check convergence +* + GO TO 60 +* +* All singular values converged, so make them positive +* + 160 CONTINUE + DO 170 I = 1, N + IF( D( I ).LT.ZERO ) THEN + D( I ) = -D( I ) +* +* Change sign of singular vectors, if desired +* + IF( NCVT.GT.0 ) + $ CALL DSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT ) + END IF + 170 CONTINUE +* +* Sort the singular values into decreasing order (insertion sort on +* singular values, but only one transposition per singular vector) +* + DO 190 I = 1, N - 1 +* +* Scan for smallest D(I) +* + ISUB = 1 + SMIN = D( 1 ) + DO 180 J = 2, N + 1 - I + IF( D( J ).LE.SMIN ) THEN + ISUB = J + SMIN = D( J ) + END IF + 180 CONTINUE + IF( ISUB.NE.N+1-I ) THEN +* +* Swap singular values and vectors +* + D( ISUB ) = D( N+1-I ) + D( N+1-I ) = SMIN + IF( NCVT.GT.0 ) + $ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ), + $ LDVT ) + IF( NRU.GT.0 ) + $ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 ) + IF( NCC.GT.0 ) + $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC ) + END IF + 190 CONTINUE + GO TO 220 +* +* Maximum number of iterations exceeded, failure to converge +* + 200 CONTINUE + INFO = 0 + DO 210 I = 1, N - 1 + IF( E( I ).NE.ZERO ) + $ INFO = INFO + 1 + 210 CONTINUE + 220 CONTINUE + RETURN +* +* End of DBDSQR +* + END diff --git a/2.3-1/src/fortran/lapack/dgebak.f b/2.3-1/src/fortran/lapack/dgebak.f new file mode 100644 index 00000000..b8e9be56 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgebak.f @@ -0,0 +1,188 @@ + SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, + $ INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOB, SIDE + INTEGER IHI, ILO, INFO, LDV, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION SCALE( * ), V( LDV, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFTV, RIGHTV + INTEGER I, II, K + DOUBLE PRECISION S +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Decode and Test the input parameters +* + RIGHTV = LSAME( SIDE, 'R' ) + LEFTV = LSAME( SIDE, 'L' ) +* + INFO = 0 + IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. + $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN + INFO = -1 + ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -7 + ELSE IF( LDV.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEBAK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + IF( M.EQ.0 ) + $ RETURN + IF( LSAME( JOB, 'N' ) ) + $ RETURN +* + IF( ILO.EQ.IHI ) + $ GO TO 30 +* +* Backward balance +* + IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN +* + IF( RIGHTV ) THEN + DO 10 I = ILO, IHI + S = SCALE( I ) + CALL DSCAL( M, S, V( I, 1 ), LDV ) + 10 CONTINUE + END IF +* + IF( LEFTV ) THEN + DO 20 I = ILO, IHI + S = ONE / SCALE( I ) + CALL DSCAL( M, S, V( I, 1 ), LDV ) + 20 CONTINUE + END IF +* + END IF +* +* Backward permutation +* +* For I = ILO-1 step -1 until 1, +* IHI+1 step 1 until N do -- +* + 30 CONTINUE + IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN + IF( RIGHTV ) THEN + DO 40 II = 1, N + I = II + IF( I.GE.ILO .AND. I.LE.IHI ) + $ GO TO 40 + IF( I.LT.ILO ) + $ I = ILO - II + K = SCALE( I ) + IF( K.EQ.I ) + $ GO TO 40 + CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 40 CONTINUE + END IF +* + IF( LEFTV ) THEN + DO 50 II = 1, N + I = II + IF( I.GE.ILO .AND. I.LE.IHI ) + $ GO TO 50 + IF( I.LT.ILO ) + $ I = ILO - II + K = SCALE( I ) + IF( K.EQ.I ) + $ GO TO 50 + CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 50 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEBAK +* + END diff --git a/2.3-1/src/fortran/lapack/dgebal.f b/2.3-1/src/fortran/lapack/dgebal.f new file mode 100644 index 00000000..1796577b --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgebal.f @@ -0,0 +1,322 @@ + SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOB + INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), SCALE( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION SCLFAC + PARAMETER ( SCLFAC = 2.0D+0 ) + DOUBLE PRECISION FACTOR + PARAMETER ( FACTOR = 0.95D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOCONV + INTEGER I, ICA, IEXC, IRA, J, K, L, M + DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, + $ SFMIN2 +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IDAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. + $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEBAL', -INFO ) + RETURN + END IF +* + K = 1 + L = N +* + IF( N.EQ.0 ) + $ GO TO 210 +* + IF( LSAME( JOB, 'N' ) ) THEN + DO 10 I = 1, N + SCALE( I ) = ONE + 10 CONTINUE + GO TO 210 + END IF +* + IF( LSAME( JOB, 'S' ) ) + $ GO TO 120 +* +* Permutation to isolate eigenvalues if possible +* + GO TO 50 +* +* Row and column exchange. +* + 20 CONTINUE + SCALE( M ) = J + IF( J.EQ.M ) + $ GO TO 30 +* + CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) + CALL DSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA ) +* + 30 CONTINUE + GO TO ( 40, 80 )IEXC +* +* Search for rows isolating an eigenvalue and push them down. +* + 40 CONTINUE + IF( L.EQ.1 ) + $ GO TO 210 + L = L - 1 +* + 50 CONTINUE + DO 70 J = L, 1, -1 +* + DO 60 I = 1, L + IF( I.EQ.J ) + $ GO TO 60 + IF( A( J, I ).NE.ZERO ) + $ GO TO 70 + 60 CONTINUE +* + M = L + IEXC = 1 + GO TO 20 + 70 CONTINUE +* + GO TO 90 +* +* Search for columns isolating an eigenvalue and push them left. +* + 80 CONTINUE + K = K + 1 +* + 90 CONTINUE + DO 110 J = K, L +* + DO 100 I = K, L + IF( I.EQ.J ) + $ GO TO 100 + IF( A( I, J ).NE.ZERO ) + $ GO TO 110 + 100 CONTINUE +* + M = K + IEXC = 2 + GO TO 20 + 110 CONTINUE +* + 120 CONTINUE + DO 130 I = K, L + SCALE( I ) = ONE + 130 CONTINUE +* + IF( LSAME( JOB, 'P' ) ) + $ GO TO 210 +* +* Balance the submatrix in rows K to L. +* +* Iterative loop for norm reduction +* + SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) + SFMAX1 = ONE / SFMIN1 + SFMIN2 = SFMIN1*SCLFAC + SFMAX2 = ONE / SFMIN2 + 140 CONTINUE + NOCONV = .FALSE. +* + DO 200 I = K, L + C = ZERO + R = ZERO +* + DO 150 J = K, L + IF( J.EQ.I ) + $ GO TO 150 + C = C + ABS( A( J, I ) ) + R = R + ABS( A( I, J ) ) + 150 CONTINUE + ICA = IDAMAX( L, A( 1, I ), 1 ) + CA = ABS( A( ICA, I ) ) + IRA = IDAMAX( N-K+1, A( I, K ), LDA ) + RA = ABS( A( I, IRA+K-1 ) ) +* +* Guard against zero C or R due to underflow. +* + IF( C.EQ.ZERO .OR. R.EQ.ZERO ) + $ GO TO 200 + G = R / SCLFAC + F = ONE + S = C + R + 160 CONTINUE + IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. + $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170 + F = F*SCLFAC + C = C*SCLFAC + CA = CA*SCLFAC + R = R / SCLFAC + G = G / SCLFAC + RA = RA / SCLFAC + GO TO 160 +* + 170 CONTINUE + G = C / SCLFAC + 180 CONTINUE + IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. + $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190 + F = F / SCLFAC + C = C / SCLFAC + G = G / SCLFAC + CA = CA / SCLFAC + R = R*SCLFAC + RA = RA*SCLFAC + GO TO 180 +* +* Now balance. +* + 190 CONTINUE + IF( ( C+R ).GE.FACTOR*S ) + $ GO TO 200 + IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN + IF( F*SCALE( I ).LE.SFMIN1 ) + $ GO TO 200 + END IF + IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN + IF( SCALE( I ).GE.SFMAX1 / F ) + $ GO TO 200 + END IF + G = ONE / F + SCALE( I ) = SCALE( I )*F + NOCONV = .TRUE. +* + CALL DSCAL( N-K+1, G, A( I, K ), LDA ) + CALL DSCAL( L, F, A( 1, I ), 1 ) +* + 200 CONTINUE +* + IF( NOCONV ) + $ GO TO 140 +* + 210 CONTINUE + ILO = K + IHI = L +* + RETURN +* +* End of DGEBAL +* + END diff --git a/2.3-1/src/fortran/lapack/dgebd2.f b/2.3-1/src/fortran/lapack/dgebd2.f new file mode 100644 index 00000000..b9eb6387 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgebd2.f @@ -0,0 +1,239 @@ + SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), + $ TAUQ( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.LT.0 ) THEN + CALL XERBLA( 'DGEBD2', -INFO ) + RETURN + END IF +* + IF( M.GE.N ) THEN +* +* Reduce to upper bidiagonal form +* + DO 10 I = 1, N +* +* Generate elementary reflector H(i) to annihilate A(i+1:m,i) +* + CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, + $ TAUQ( I ) ) + D( I ) = A( I, I ) + A( I, I ) = ONE +* +* Apply H(i) to A(i:m,i+1:n) from the left +* + IF( I.LT.N ) + $ CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), + $ A( I, I+1 ), LDA, WORK ) + A( I, I ) = D( I ) +* + IF( I.LT.N ) THEN +* +* Generate elementary reflector G(i) to annihilate +* A(i,i+2:n) +* + CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), + $ LDA, TAUP( I ) ) + E( I ) = A( I, I+1 ) + A( I, I+1 ) = ONE +* +* Apply G(i) to A(i+1:m,i+1:n) from the right +* + CALL DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, + $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) + A( I, I+1 ) = E( I ) + ELSE + TAUP( I ) = ZERO + END IF + 10 CONTINUE + ELSE +* +* Reduce to lower bidiagonal form +* + DO 20 I = 1, M +* +* Generate elementary reflector G(i) to annihilate A(i,i+1:n) +* + CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, + $ TAUP( I ) ) + D( I ) = A( I, I ) + A( I, I ) = ONE +* +* Apply G(i) to A(i+1:m,i:n) from the right +* + IF( I.LT.M ) + $ CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAUP( I ), A( I+1, I ), LDA, WORK ) + A( I, I ) = D( I ) +* + IF( I.LT.M ) THEN +* +* Generate elementary reflector H(i) to annihilate +* A(i+2:m,i) +* + CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, + $ TAUQ( I ) ) + E( I ) = A( I+1, I ) + A( I+1, I ) = ONE +* +* Apply H(i) to A(i+1:m,i+1:n) from the left +* + CALL DLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ), + $ A( I+1, I+1 ), LDA, WORK ) + A( I+1, I ) = E( I ) + ELSE + TAUQ( I ) = ZERO + END IF + 20 CONTINUE + END IF + RETURN +* +* End of DGEBD2 +* + END diff --git a/2.3-1/src/fortran/lapack/dgebrd.f b/2.3-1/src/fortran/lapack/dgebrd.f new file mode 100644 index 00000000..6544715d --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgebrd.f @@ -0,0 +1,268 @@ + SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, + $ INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), + $ TAUQ( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, + $ NBMIN, NX + DOUBLE PRECISION WS +* .. +* .. External Subroutines .. + EXTERNAL DGEBD2, DGEMM, DLABRD, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) ) + LWKOPT = ( M+N )*NB + WORK( 1 ) = DBLE( LWKOPT ) + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + IF( INFO.LT.0 ) THEN + CALL XERBLA( 'DGEBRD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + WS = MAX( M, N ) + LDWRKX = M + LDWRKY = N +* + IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN +* +* Set the crossover point NX. +* + NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) ) +* +* Determine when to switch from blocked to unblocked code. +* + IF( NX.LT.MINMN ) THEN + WS = ( M+N )*NB + IF( LWORK.LT.WS ) THEN +* +* Not enough work space for the optimal NB, consider using +* a smaller block size. +* + NBMIN = ILAENV( 2, 'DGEBRD', ' ', M, N, -1, -1 ) + IF( LWORK.GE.( M+N )*NBMIN ) THEN + NB = LWORK / ( M+N ) + ELSE + NB = 1 + NX = MINMN + END IF + END IF + END IF + ELSE + NX = MINMN + END IF +* + DO 30 I = 1, MINMN - NX, NB +* +* 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 +* + CALL DLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ), + $ TAUQ( I ), TAUP( I ), WORK, 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' +* + CALL DGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1, + $ NB, -ONE, A( I+NB, I ), LDA, + $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE, + $ A( I+NB, I+NB ), LDA ) + CALL DGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, + $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, + $ ONE, A( I+NB, I+NB ), LDA ) +* +* Copy diagonal and off-diagonal elements of B back into A +* + IF( M.GE.N ) THEN + DO 10 J = I, I + NB - 1 + A( J, J ) = D( J ) + A( J, J+1 ) = E( J ) + 10 CONTINUE + ELSE + DO 20 J = I, I + NB - 1 + A( J, J ) = D( J ) + A( J+1, J ) = E( J ) + 20 CONTINUE + END IF + 30 CONTINUE +* +* Use unblocked code to reduce the remainder of the matrix +* + CALL DGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ), + $ TAUQ( I ), TAUP( I ), WORK, IINFO ) + WORK( 1 ) = WS + RETURN +* +* End of DGEBRD +* + END diff --git a/2.3-1/src/fortran/lapack/dgecon.f b/2.3-1/src/fortran/lapack/dgecon.f new file mode 100644 index 00000000..807cafca --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgecon.f @@ -0,0 +1,185 @@ + SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, + $ INFO ) +* +* -- LAPACK routine (version 3.1) -- +* 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 .. + CHARACTER NORM + INTEGER INFO, LDA, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ONENRM + CHARACTER NORMIN + INTEGER IX, KASE, KASE1 + DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IDAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) + IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGECON', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.EQ.ZERO ) THEN + RETURN + END IF +* + SMLNUM = DLAMCH( 'Safe minimum' ) +* +* Estimate the norm of inv(A). +* + AINVNM = ZERO + NORMIN = 'N' + IF( ONENRM ) THEN + KASE1 = 1 + ELSE + KASE1 = 2 + END IF + KASE = 0 + 10 CONTINUE + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.KASE1 ) THEN +* +* Multiply by inv(L). +* + CALL DLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A, + $ LDA, WORK, SL, WORK( 2*N+1 ), INFO ) +* +* Multiply by inv(U). +* + CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, + $ A, LDA, WORK, SU, WORK( 3*N+1 ), INFO ) + ELSE +* +* Multiply by inv(U'). +* + CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A, + $ LDA, WORK, SU, WORK( 3*N+1 ), INFO ) +* +* Multiply by inv(L'). +* + CALL DLATRS( 'Lower', 'Transpose', 'Unit', NORMIN, N, A, + $ LDA, WORK, SL, WORK( 2*N+1 ), INFO ) + END IF +* +* Divide X by 1/(SL*SU) if doing so will not cause overflow. +* + SCALE = SL*SU + NORMIN = 'Y' + IF( SCALE.NE.ONE ) THEN + IX = IDAMAX( N, WORK, 1 ) + IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) + $ GO TO 20 + CALL DRSCL( N, SCALE, WORK, 1 ) + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + 20 CONTINUE + RETURN +* +* End of DGECON +* + END diff --git a/2.3-1/src/fortran/lapack/dgeequ.f b/2.3-1/src/fortran/lapack/dgeequ.f new file mode 100644 index 00000000..b703116e --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgeequ.f @@ -0,0 +1,225 @@ + SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N + DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEEQU', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + ROWCND = ONE + COLCND = ONE + AMAX = ZERO + RETURN + END IF +* +* Get machine constants. +* + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM +* +* Compute row scale factors. +* + DO 10 I = 1, M + R( I ) = ZERO + 10 CONTINUE +* +* Find the maximum element in each row. +* + DO 30 J = 1, N + DO 20 I = 1, M + R( I ) = MAX( R( I ), ABS( A( I, J ) ) ) + 20 CONTINUE + 30 CONTINUE +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 40 I = 1, M + RCMAX = MAX( RCMAX, R( I ) ) + RCMIN = MIN( RCMIN, R( I ) ) + 40 CONTINUE + AMAX = RCMAX +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 50 I = 1, M + IF( R( I ).EQ.ZERO ) THEN + INFO = I + RETURN + END IF + 50 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 60 I = 1, M + R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) + 60 CONTINUE +* +* Compute ROWCND = min(R(I)) / max(R(I)) +* + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* +* Compute column scale factors +* + DO 70 J = 1, N + C( J ) = ZERO + 70 CONTINUE +* +* Find the maximum element in each column, +* assuming the row scaling computed above. +* + DO 90 J = 1, N + DO 80 I = 1, M + C( J ) = MAX( C( J ), ABS( A( I, J ) )*R( I ) ) + 80 CONTINUE + 90 CONTINUE +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 100 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 100 CONTINUE +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 110 J = 1, N + IF( C( J ).EQ.ZERO ) THEN + INFO = M + J + RETURN + END IF + 110 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 120 J = 1, N + C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) + 120 CONTINUE +* +* Compute COLCND = min(C(J)) / max(C(J)) +* + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* + RETURN +* +* End of DGEEQU +* + END diff --git a/2.3-1/src/fortran/lapack/dgees.f b/2.3-1/src/fortran/lapack/dgees.f new file mode 100644 index 00000000..96ba8019 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgees.f @@ -0,0 +1,434 @@ + SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, + $ VS, LDVS, WORK, LWORK, BWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBVS, SORT + INTEGER INFO, LDA, LDVS, LWORK, N, SDIM +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ) + DOUBLE PRECISION A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ), + $ WR( * ) +* .. +* .. Function Arguments .. + LOGICAL SELECT + EXTERNAL SELECT +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTST, + $ WANTVS + INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL, + $ IHI, ILO, INXT, IP, ITAU, IWRK, MAXWRK, MINWRK + DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM +* .. +* .. Local Arrays .. + INTEGER IDUM( 1 ) + DOUBLE PRECISION DUM( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, + $ DLABAD, DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + WANTVS = LSAME( JOBVS, 'V' ) + WANTST = LSAME( SORT, 'S' ) + IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN + INFO = -11 + END IF +* +* 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.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + ELSE + MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) + MINWRK = 3*N +* + CALL DHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS, + $ WORK, -1, IEVAL ) + HSWORK = WORK( 1 ) +* + IF( .NOT.WANTVS ) THEN + MAXWRK = MAX( MAXWRK, N + HSWORK ) + ELSE + MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, + $ 'DORGHR', ' ', N, 1, N, -1 ) ) + MAXWRK = MAX( MAXWRK, N + HSWORK ) + END IF + END IF + WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEES ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + SDIM = 0 + RETURN + END IF +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = DLANGE( 'M', N, N, A, LDA, DUM ) + SCALEA = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + SCALEA = .TRUE. + CSCALE = SMLNUM + ELSE IF( ANRM.GT.BIGNUM ) THEN + SCALEA = .TRUE. + CSCALE = BIGNUM + END IF + IF( SCALEA ) + $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) +* +* Permute the matrix to make it more nearly triangular +* (Workspace: need N) +* + IBAL = 1 + CALL DGEBAL( 'P', N, A, 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 + CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* + IF( WANTVS ) THEN +* +* Copy Householder vectors to VS +* + CALL DLACPY( 'L', N, N, A, LDA, VS, LDVS ) +* +* Generate orthogonal matrix in VS +* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) +* + CALL DORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) + END IF +* + SDIM = 0 +* +* Perform QR iteration, accumulating Schur vectors in VS if desired +* (Workspace: need N+1, prefer N+HSWORK (see comments) ) +* + IWRK = ITAU + CALL DHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS, + $ WORK( IWRK ), LWORK-IWRK+1, IEVAL ) + IF( IEVAL.GT.0 ) + $ INFO = IEVAL +* +* Sort eigenvalues if desired +* + IF( WANTST .AND. INFO.EQ.0 ) THEN + IF( SCALEA ) THEN + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR ) + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR ) + END IF + DO 10 I = 1, N + BWORK( I ) = SELECT( WR( I ), WI( I ) ) + 10 CONTINUE +* +* Reorder eigenvalues and transform Schur vectors +* (Workspace: none needed) +* + CALL DTRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI, + $ SDIM, S, SEP, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, + $ ICOND ) + IF( ICOND.GT.0 ) + $ INFO = N + ICOND + END IF +* + IF( WANTVS ) THEN +* +* Undo balancing +* (Workspace: need N) +* + CALL DGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS, + $ IERR ) + END IF +* + IF( SCALEA ) THEN +* +* Undo scaling for the Schur form of A +* + CALL DLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR ) + CALL DCOPY( N, A, LDA+1, WR, 1 ) + IF( CSCALE.EQ.SMLNUM ) THEN +* +* If scaling back towards underflow, adjust WI if an +* offdiagonal element of a 2-by-2 block in the Schur form +* underflows. +* + IF( IEVAL.GT.0 ) THEN + I1 = IEVAL + 1 + I2 = IHI - 1 + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, + $ MAX( ILO-1, 1 ), IERR ) + ELSE IF( WANTST ) THEN + I1 = 1 + I2 = N - 1 + ELSE + I1 = ILO + I2 = IHI - 1 + END IF + INXT = I1 - 1 + DO 20 I = I1, I2 + IF( I.LT.INXT ) + $ GO TO 20 + IF( WI( I ).EQ.ZERO ) THEN + INXT = I + 1 + ELSE + IF( A( I+1, I ).EQ.ZERO ) THEN + WI( I ) = ZERO + WI( I+1 ) = ZERO + ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ. + $ ZERO ) THEN + WI( I ) = ZERO + WI( I+1 ) = ZERO + IF( I.GT.1 ) + $ CALL DSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 ) + IF( N.GT.I+1 ) + $ CALL DSWAP( N-I-1, A( I, I+2 ), LDA, + $ A( I+1, I+2 ), LDA ) + IF( WANTVS ) THEN + CALL DSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 ) + END IF + A( I, I+1 ) = A( I+1, I ) + A( I+1, I ) = ZERO + END IF + INXT = I + 2 + END IF + 20 CONTINUE + END IF +* +* Undo scaling for the imaginary part of the eigenvalues +* + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1, + $ WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR ) + END IF +* + IF( WANTST .AND. INFO.EQ.0 ) THEN +* +* Check if reordering successful +* + LASTSL = .TRUE. + LST2SL = .TRUE. + SDIM = 0 + IP = 0 + DO 30 I = 1, N + CURSL = SELECT( WR( I ), WI( I ) ) + IF( WI( I ).EQ.ZERO ) THEN + IF( CURSL ) + $ SDIM = SDIM + 1 + IP = 0 + IF( CURSL .AND. .NOT.LASTSL ) + $ INFO = N + 2 + ELSE + IF( IP.EQ.1 ) THEN +* +* Last eigenvalue of conjugate pair +* + CURSL = CURSL .OR. LASTSL + LASTSL = CURSL + IF( CURSL ) + $ SDIM = SDIM + 2 + IP = -1 + IF( CURSL .AND. .NOT.LST2SL ) + $ INFO = N + 2 + ELSE +* +* First eigenvalue of conjugate pair +* + IP = 1 + END IF + END IF + LST2SL = LASTSL + LASTSL = CURSL + 30 CONTINUE + END IF +* + WORK( 1 ) = MAXWRK + RETURN +* +* End of DGEES +* + END diff --git a/2.3-1/src/fortran/lapack/dgeesx.f b/2.3-1/src/fortran/lapack/dgeesx.f new file mode 100644 index 00000000..deb30ab2 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgeesx.f @@ -0,0 +1,527 @@ + SUBROUTINE DGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, + $ WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, + $ IWORK, LIWORK, BWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBVS, SENSE, SORT + INTEGER INFO, LDA, LDVS, LIWORK, LWORK, N, SDIM + DOUBLE PRECISION RCONDE, RCONDV +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ), + $ WR( * ) +* .. +* .. Function Arguments .. + LOGICAL SELECT + EXTERNAL SELECT +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTSB, + $ WANTSE, WANTSN, WANTST, WANTSV, WANTVS + INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL, + $ IHI, ILO, INXT, IP, ITAU, IWRK, LIWRK, LWRK, + $ MAXWRK, MINWRK + DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SMLNUM +* .. +* .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, + $ DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, ILAENV, DLABAD, DLAMCH, DLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + 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.EQ.-1 .OR. LIWORK.EQ.-1 ) + IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR. + $ ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN + INFO = -12 + END IF +* +* 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.EQ.0 ) THEN + LIWRK = 1 + IF( N.EQ.0 ) THEN + MINWRK = 1 + LWRK = 1 + ELSE + MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) + MINWRK = 3*N +* + CALL DHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS, + $ WORK, -1, IEVAL ) + HSWORK = WORK( 1 ) +* + IF( .NOT.WANTVS ) THEN + MAXWRK = MAX( MAXWRK, N + HSWORK ) + ELSE + MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, + $ 'DORGHR', ' ', N, 1, N, -1 ) ) + MAXWRK = MAX( MAXWRK, N + HSWORK ) + END IF + LWRK = MAXWRK + IF( .NOT.WANTSN ) + $ LWRK = MAX( LWRK, N + ( N*N )/2 ) + IF( WANTSV .OR. WANTSB ) + $ LIWRK = ( N*N )/4 + END IF + IWORK( 1 ) = LIWRK + WORK( 1 ) = LWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -16 + ELSE IF( LIWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -18 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEESX', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + SDIM = 0 + RETURN + END IF +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = DLANGE( 'M', N, N, A, LDA, DUM ) + SCALEA = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + SCALEA = .TRUE. + CSCALE = SMLNUM + ELSE IF( ANRM.GT.BIGNUM ) THEN + SCALEA = .TRUE. + CSCALE = BIGNUM + END IF + IF( SCALEA ) + $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) +* +* Permute the matrix to make it more nearly triangular +* (RWorkspace: need N) +* + IBAL = 1 + CALL DGEBAL( 'P', N, A, 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 + CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* + IF( WANTVS ) THEN +* +* Copy Householder vectors to VS +* + CALL DLACPY( 'L', N, N, A, LDA, VS, LDVS ) +* +* Generate orthogonal matrix in VS +* (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) +* + CALL DORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) + END IF +* + SDIM = 0 +* +* Perform QR iteration, accumulating Schur vectors in VS if desired +* (RWorkspace: need N+1, prefer N+HSWORK (see comments) ) +* + IWRK = ITAU + CALL DHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS, + $ WORK( IWRK ), LWORK-IWRK+1, IEVAL ) + IF( IEVAL.GT.0 ) + $ INFO = IEVAL +* +* Sort eigenvalues if desired +* + IF( WANTST .AND. INFO.EQ.0 ) THEN + IF( SCALEA ) THEN + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR ) + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR ) + END IF + DO 10 I = 1, N + BWORK( I ) = SELECT( WR( I ), WI( I ) ) + 10 CONTINUE +* +* 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 ) +* + CALL DTRSEN( SENSE, JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI, + $ SDIM, RCONDE, RCONDV, WORK( IWRK ), LWORK-IWRK+1, + $ IWORK, LIWORK, ICOND ) + IF( .NOT.WANTSN ) + $ MAXWRK = MAX( MAXWRK, N+2*SDIM*( N-SDIM ) ) + IF( ICOND.EQ.-15 ) THEN +* +* Not enough real workspace +* + INFO = -16 + ELSE IF( ICOND.EQ.-17 ) THEN +* +* Not enough integer workspace +* + INFO = -18 + ELSE IF( ICOND.GT.0 ) THEN +* +* DTRSEN failed to reorder or to restore standard Schur form +* + INFO = ICOND + N + END IF + END IF +* + IF( WANTVS ) THEN +* +* Undo balancing +* (RWorkspace: need N) +* + CALL DGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS, + $ IERR ) + END IF +* + IF( SCALEA ) THEN +* +* Undo scaling for the Schur form of A +* + CALL DLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR ) + CALL DCOPY( N, A, LDA+1, WR, 1 ) + IF( ( WANTSV .OR. WANTSB ) .AND. INFO.EQ.0 ) THEN + DUM( 1 ) = RCONDV + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR ) + RCONDV = DUM( 1 ) + END IF + IF( CSCALE.EQ.SMLNUM ) THEN +* +* If scaling back towards underflow, adjust WI if an +* offdiagonal element of a 2-by-2 block in the Schur form +* underflows. +* + IF( IEVAL.GT.0 ) THEN + I1 = IEVAL + 1 + I2 = IHI - 1 + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N, + $ IERR ) + ELSE IF( WANTST ) THEN + I1 = 1 + I2 = N - 1 + ELSE + I1 = ILO + I2 = IHI - 1 + END IF + INXT = I1 - 1 + DO 20 I = I1, I2 + IF( I.LT.INXT ) + $ GO TO 20 + IF( WI( I ).EQ.ZERO ) THEN + INXT = I + 1 + ELSE + IF( A( I+1, I ).EQ.ZERO ) THEN + WI( I ) = ZERO + WI( I+1 ) = ZERO + ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ. + $ ZERO ) THEN + WI( I ) = ZERO + WI( I+1 ) = ZERO + IF( I.GT.1 ) + $ CALL DSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 ) + IF( N.GT.I+1 ) + $ CALL DSWAP( N-I-1, A( I, I+2 ), LDA, + $ A( I+1, I+2 ), LDA ) + CALL DSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 ) + A( I, I+1 ) = A( I+1, I ) + A( I+1, I ) = ZERO + END IF + INXT = I + 2 + END IF + 20 CONTINUE + END IF + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1, + $ WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR ) + END IF +* + IF( WANTST .AND. INFO.EQ.0 ) THEN +* +* Check if reordering successful +* + LASTSL = .TRUE. + LST2SL = .TRUE. + SDIM = 0 + IP = 0 + DO 30 I = 1, N + CURSL = SELECT( WR( I ), WI( I ) ) + IF( WI( I ).EQ.ZERO ) THEN + IF( CURSL ) + $ SDIM = SDIM + 1 + IP = 0 + IF( CURSL .AND. .NOT.LASTSL ) + $ INFO = N + 2 + ELSE + IF( IP.EQ.1 ) THEN +* +* Last eigenvalue of conjugate pair +* + CURSL = CURSL .OR. LASTSL + LASTSL = CURSL + IF( CURSL ) + $ SDIM = SDIM + 2 + IP = -1 + IF( CURSL .AND. .NOT.LST2SL ) + $ INFO = N + 2 + ELSE +* +* First eigenvalue of conjugate pair +* + IP = 1 + END IF + END IF + LST2SL = LASTSL + LASTSL = CURSL + 30 CONTINUE + END IF +* + WORK( 1 ) = MAXWRK + IF( WANTSV .OR. WANTSB ) THEN + IWORK( 1 ) = MAX( 1, SDIM*( N-SDIM ) ) + ELSE + IWORK( 1 ) = 1 + END IF +* + RETURN +* +* End of DGEESX +* + END diff --git a/2.3-1/src/fortran/lapack/dgeev.f b/2.3-1/src/fortran/lapack/dgeev.f new file mode 100644 index 00000000..50e08a9c --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgeev.f @@ -0,0 +1,423 @@ + SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, + $ LDVR, WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBVL, JOBVR + INTEGER INFO, LDA, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WI( * ), WORK( * ), WR( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, SCALEA, WANTVL, WANTVR + CHARACTER SIDE + INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K, + $ MAXWRK, MINWRK, NOUT + DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, + $ SN +* .. +* .. Local Arrays .. + LOGICAL SELECT( 1 ) + DOUBLE PRECISION DUM( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, + $ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2 + EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DLANGE, DLAPY2, + $ DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + WANTVL = LSAME( JOBVL, 'V' ) + WANTVR = LSAME( JOBVR, 'V' ) + IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN + INFO = -9 + ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN + INFO = -11 + END IF +* +* 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.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + ELSE + MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) + IF( WANTVL ) THEN + MINWRK = 4*N + MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, + $ 'DORGHR', ' ', N, 1, N, -1 ) ) + CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL, + $ WORK, -1, INFO ) + HSWORK = WORK( 1 ) + MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) + MAXWRK = MAX( MAXWRK, 4*N ) + ELSE IF( WANTVR ) THEN + MINWRK = 4*N + MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, + $ 'DORGHR', ' ', N, 1, N, -1 ) ) + CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR, + $ WORK, -1, INFO ) + HSWORK = WORK( 1 ) + MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) + MAXWRK = MAX( MAXWRK, 4*N ) + ELSE + MINWRK = 3*N + CALL DHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR, LDVR, + $ WORK, -1, INFO ) + HSWORK = WORK( 1 ) + MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) + END IF + MAXWRK = MAX( MAXWRK, MINWRK ) + END IF + WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEEV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = DLANGE( 'M', N, N, A, LDA, DUM ) + SCALEA = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + SCALEA = .TRUE. + CSCALE = SMLNUM + ELSE IF( ANRM.GT.BIGNUM ) THEN + SCALEA = .TRUE. + CSCALE = BIGNUM + END IF + IF( SCALEA ) + $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) +* +* Balance the matrix +* (Workspace: need N) +* + IBAL = 1 + CALL DGEBAL( 'B', N, A, 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 + CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* + IF( WANTVL ) THEN +* +* Want left eigenvectors +* Copy Householder vectors to VL +* + SIDE = 'L' + CALL DLACPY( 'L', N, N, A, LDA, VL, LDVL ) +* +* Generate orthogonal matrix in VL +* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) +* + CALL DORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* +* Perform QR iteration, accumulating Schur vectors in VL +* (Workspace: need N+1, prefer N+HSWORK (see comments) ) +* + IWRK = ITAU + CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL, + $ WORK( IWRK ), LWORK-IWRK+1, INFO ) +* + IF( WANTVR ) THEN +* +* Want left and right eigenvectors +* Copy Schur vectors to VR +* + SIDE = 'B' + CALL DLACPY( 'F', N, N, VL, LDVL, VR, LDVR ) + END IF +* + ELSE IF( WANTVR ) THEN +* +* Want right eigenvectors +* Copy Householder vectors to VR +* + SIDE = 'R' + CALL DLACPY( 'L', N, N, A, LDA, VR, LDVR ) +* +* Generate orthogonal matrix in VR +* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) +* + CALL DORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* +* Perform QR iteration, accumulating Schur vectors in VR +* (Workspace: need N+1, prefer N+HSWORK (see comments) ) +* + IWRK = ITAU + CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, + $ WORK( IWRK ), LWORK-IWRK+1, INFO ) +* + ELSE +* +* Compute eigenvalues only +* (Workspace: need N+1, prefer N+HSWORK (see comments) ) +* + IWRK = ITAU + CALL DHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, + $ WORK( IWRK ), LWORK-IWRK+1, INFO ) + END IF +* +* If INFO > 0 from DHSEQR, then quit +* + IF( INFO.GT.0 ) + $ GO TO 50 +* + IF( WANTVL .OR. WANTVR ) THEN +* +* Compute left and/or right eigenvectors +* (Workspace: need 4*N) +* + CALL DTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ N, NOUT, WORK( IWRK ), IERR ) + END IF +* + IF( WANTVL ) THEN +* +* Undo balancing of left eigenvectors +* (Workspace: need N) +* + CALL DGEBAK( 'B', 'L', N, ILO, IHI, WORK( IBAL ), N, VL, LDVL, + $ IERR ) +* +* Normalize left eigenvectors and make largest component real +* + DO 20 I = 1, N + IF( WI( I ).EQ.ZERO ) THEN + SCL = ONE / DNRM2( N, VL( 1, I ), 1 ) + CALL DSCAL( N, SCL, VL( 1, I ), 1 ) + ELSE IF( WI( I ).GT.ZERO ) THEN + SCL = ONE / DLAPY2( DNRM2( N, VL( 1, I ), 1 ), + $ DNRM2( N, VL( 1, I+1 ), 1 ) ) + CALL DSCAL( N, SCL, VL( 1, I ), 1 ) + CALL DSCAL( N, SCL, VL( 1, I+1 ), 1 ) + DO 10 K = 1, N + WORK( IWRK+K-1 ) = VL( K, I )**2 + VL( K, I+1 )**2 + 10 CONTINUE + K = IDAMAX( N, WORK( IWRK ), 1 ) + CALL DLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R ) + CALL DROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN ) + VL( K, I+1 ) = ZERO + END IF + 20 CONTINUE + END IF +* + IF( WANTVR ) THEN +* +* Undo balancing of right eigenvectors +* (Workspace: need N) +* + CALL DGEBAK( 'B', 'R', N, ILO, IHI, WORK( IBAL ), N, VR, LDVR, + $ IERR ) +* +* Normalize right eigenvectors and make largest component real +* + DO 40 I = 1, N + IF( WI( I ).EQ.ZERO ) THEN + SCL = ONE / DNRM2( N, VR( 1, I ), 1 ) + CALL DSCAL( N, SCL, VR( 1, I ), 1 ) + ELSE IF( WI( I ).GT.ZERO ) THEN + SCL = ONE / DLAPY2( DNRM2( N, VR( 1, I ), 1 ), + $ DNRM2( N, VR( 1, I+1 ), 1 ) ) + CALL DSCAL( N, SCL, VR( 1, I ), 1 ) + CALL DSCAL( N, SCL, VR( 1, I+1 ), 1 ) + DO 30 K = 1, N + WORK( IWRK+K-1 ) = VR( K, I )**2 + VR( K, I+1 )**2 + 30 CONTINUE + K = IDAMAX( N, WORK( IWRK ), 1 ) + CALL DLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R ) + CALL DROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN ) + VR( K, I+1 ) = ZERO + END IF + 40 CONTINUE + END IF +* +* Undo scaling if necessary +* + 50 CONTINUE + IF( SCALEA ) THEN + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ), + $ MAX( N-INFO, 1 ), IERR ) + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ), + $ MAX( N-INFO, 1 ), IERR ) + IF( INFO.GT.0 ) THEN + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N, + $ IERR ) + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N, + $ IERR ) + END IF + END IF +* + WORK( 1 ) = MAXWRK + RETURN +* +* End of DGEEV +* + END diff --git a/2.3-1/src/fortran/lapack/dgegs.f b/2.3-1/src/fortran/lapack/dgegs.f new file mode 100644 index 00000000..85c32531 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgegs.f @@ -0,0 +1,438 @@ + SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, + $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBVSL, JOBVSR + INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), + $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), + $ VSR( LDVSR, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY + INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO, + $ IRIGHT, IROWS, ITAU, IWORK, LOPT, LWKMIN, + $ LWKOPT, NB, NB1, NB2, NB3 + DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, + $ SAFMIN, SMLNUM +* .. +* .. External Subroutines .. + EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLACPY, + $ DLASCL, DLASET, DORGQR, DORMQR, XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX +* .. +* .. Executable Statements .. +* +* Decode the input arguments +* + IF( LSAME( JOBVSL, 'N' ) ) THEN + IJOBVL = 1 + ILVSL = .FALSE. + ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN + IJOBVL = 2 + ILVSL = .TRUE. + ELSE + IJOBVL = -1 + ILVSL = .FALSE. + END IF +* + IF( LSAME( JOBVSR, 'N' ) ) THEN + IJOBVR = 1 + ILVSR = .FALSE. + ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN + IJOBVR = 2 + ILVSR = .TRUE. + ELSE + IJOBVR = -1 + ILVSR = .FALSE. + END IF +* +* Test the input arguments +* + LWKMIN = MAX( 4*N, 1 ) + LWKOPT = LWKMIN + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + INFO = 0 + IF( IJOBVL.LE.0 ) THEN + INFO = -1 + ELSE IF( IJOBVR.LE.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN + INFO = -14 + ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN + INFO = -16 + END IF +* + IF( INFO.EQ.0 ) THEN + NB1 = ILAENV( 1, 'DGEQRF', ' ', N, N, -1, -1 ) + NB2 = ILAENV( 1, 'DORMQR', ' ', N, N, N, -1 ) + NB3 = ILAENV( 1, 'DORGQR', ' ', N, N, N, -1 ) + NB = MAX( NB1, NB2, NB3 ) + LOPT = 2*N + N*( NB+1 ) + WORK( 1 ) = LOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEGS ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Get machine constants +* + EPS = DLAMCH( 'E' )*DLAMCH( 'B' ) + SAFMIN = DLAMCH( 'S' ) + SMLNUM = N*SAFMIN / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = DLANGE( 'M', N, N, A, LDA, WORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF +* + IF( ILASCL ) THEN + CALL DLASCL( 'G', -1, -1, ANRM, ANRMTO, N, N, A, LDA, IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = N + 9 + RETURN + END IF + END IF +* +* Scale B if max element outside range [SMLNUM,BIGNUM] +* + BNRM = DLANGE( 'M', N, N, B, LDB, WORK ) + ILBSCL = .FALSE. + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + BNRMTO = SMLNUM + ILBSCL = .TRUE. + ELSE IF( BNRM.GT.BIGNUM ) THEN + BNRMTO = BIGNUM + ILBSCL = .TRUE. + END IF +* + IF( ILBSCL ) THEN + CALL DLASCL( 'G', -1, -1, BNRM, BNRMTO, N, N, B, LDB, IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = N + 9 + RETURN + END IF + END IF +* +* 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 + CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), WORK( IWORK ), IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = N + 1 + GO TO 10 + END IF +* +* 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 + CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), + $ WORK( IWORK ), LWORK+1-IWORK, IINFO ) + IF( IINFO.GE.0 ) + $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) + IF( IINFO.NE.0 ) THEN + INFO = N + 2 + GO TO 10 + END IF +* + CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, + $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ), + $ LWORK+1-IWORK, IINFO ) + IF( IINFO.GE.0 ) + $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) + IF( IINFO.NE.0 ) THEN + INFO = N + 3 + GO TO 10 + END IF +* + IF( ILVSL ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL ) + CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, + $ VSL( ILO+1, ILO ), LDVSL ) + CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, + $ WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK, + $ IINFO ) + IF( IINFO.GE.0 ) + $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) + IF( IINFO.NE.0 ) THEN + INFO = N + 4 + GO TO 10 + END IF + END IF +* + IF( ILVSR ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR ) +* +* Reduce to generalized Hessenberg form +* + CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, + $ LDVSL, VSR, LDVSR, IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = N + 5 + GO TO 10 + END IF +* +* Perform QZ algorithm, computing Schur vectors if desired +* Workspace layout: ("work..." must have at least 1 word) +* left_permutation, right_permutation, work... +* + IWORK = ITAU + CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, + $ WORK( IWORK ), LWORK+1-IWORK, IINFO ) + IF( IINFO.GE.0 ) + $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) + IF( IINFO.NE.0 ) THEN + IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN + INFO = IINFO + ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN + INFO = IINFO - N + ELSE + INFO = N + 6 + END IF + GO TO 10 + END IF +* +* Apply permutation to VSL and VSR +* + IF( ILVSL ) THEN + CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), N, VSL, LDVSL, IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = N + 7 + GO TO 10 + END IF + END IF + IF( ILVSR ) THEN + CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), N, VSR, LDVSR, IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = N + 8 + GO TO 10 + END IF + END IF +* +* Undo scaling +* + IF( ILASCL ) THEN + CALL DLASCL( 'H', -1, -1, ANRMTO, ANRM, N, N, A, LDA, IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = N + 9 + RETURN + END IF + CALL DLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAR, N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = N + 9 + RETURN + END IF + CALL DLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAI, N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = N + 9 + RETURN + END IF + END IF +* + IF( ILBSCL ) THEN + CALL DLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = N + 9 + RETURN + END IF + CALL DLASCL( 'G', -1, -1, BNRMTO, BNRM, N, 1, BETA, N, IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = N + 9 + RETURN + END IF + END IF +* + 10 CONTINUE + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DGEGS +* + END diff --git a/2.3-1/src/fortran/lapack/dgehd2.f b/2.3-1/src/fortran/lapack/dgehd2.f new file mode 100644 index 00000000..28d1cc8d --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgehd2.f @@ -0,0 +1,149 @@ + SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION AII +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEHD2', -INFO ) + RETURN + END IF +* + DO 10 I = ILO, IHI - 1 +* +* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) +* + CALL DLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAU( I ) ) + AII = A( I+1, I ) + A( I+1, I ) = ONE +* +* Apply H(i) to A(1:ihi,i+1:ihi) from the right +* + CALL DLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), + $ A( 1, I+1 ), LDA, WORK ) +* +* Apply H(i) to A(i+1:ihi,i+1:n) from the left +* + CALL DLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ), + $ A( I+1, I+1 ), LDA, WORK ) +* + A( I+1, I ) = AII + 10 CONTINUE +* + RETURN +* +* End of DGEHD2 +* + END diff --git a/2.3-1/src/fortran/lapack/dgehrd.f b/2.3-1/src/fortran/lapack/dgehrd.f new file mode 100644 index 00000000..339ee400 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgehrd.f @@ -0,0 +1,273 @@ + SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, + $ ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB, + $ NBMIN, NH, NX + DOUBLE PRECISION EI +* .. +* .. Local Arrays .. + DOUBLE PRECISION T( LDT, NBMAX ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DGEHD2, DGEMM, DLAHR2, DLARFB, DTRMM, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEHRD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero +* + DO 10 I = 1, ILO - 1 + TAU( I ) = ZERO + 10 CONTINUE + DO 20 I = MAX( 1, IHI ), N - 1 + TAU( I ) = ZERO + 20 CONTINUE +* +* Quick return if possible +* + NH = IHI - ILO + 1 + IF( NH.LE.1 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine the block size +* + NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) + NBMIN = 2 + IWS = 1 + IF( NB.GT.1 .AND. NB.LT.NH ) THEN +* +* Determine when to cross over from blocked to unblocked code +* (last block is always handled by unblocked code) +* + NX = MAX( NB, ILAENV( 3, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) + IF( NX.LT.NH ) THEN +* +* Determine if workspace is large enough for blocked code +* + IWS = N*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: determine the +* minimum value of NB, and reduce NB or force use of +* unblocked code +* + NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N, ILO, IHI, + $ -1 ) ) + IF( LWORK.GE.N*NBMIN ) THEN + NB = LWORK / N + ELSE + NB = 1 + END IF + END IF + END IF + END IF + LDWORK = N +* + IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN +* +* Use unblocked code below +* + I = ILO +* + ELSE +* +* Use blocked code +* + DO 40 I = ILO, IHI - 1 - NX, NB + IB = MIN( NB, IHI-I ) +* +* 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 +* + CALL DLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, + $ WORK, 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( I+IB, I+IB-1 ) = ONE + CALL DGEMM( 'No transpose', 'Transpose', + $ IHI, IHI-I-IB+1, + $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, + $ A( 1, I+IB ), LDA ) + A( I+IB, I+IB-1 ) = EI +* +* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the +* right +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', + $ 'Unit', I, IB-1, + $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) + DO 30 J = 0, IB-2 + CALL DAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, + $ A( 1, I+J+1 ), 1 ) + 30 CONTINUE +* +* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the +* left +* + CALL DLARFB( 'Left', 'Transpose', 'Forward', + $ 'Columnwise', + $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT, + $ A( I+1, I+IB ), LDA, WORK, LDWORK ) + 40 CONTINUE + END IF +* +* Use unblocked code to reduce the rest of the matrix +* + CALL DGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO ) + WORK( 1 ) = IWS +* + RETURN +* +* End of DGEHRD +* + END diff --git a/2.3-1/src/fortran/lapack/dgelq2.f b/2.3-1/src/fortran/lapack/dgelq2.f new file mode 100644 index 00000000..f3540505 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgelq2.f @@ -0,0 +1,121 @@ + SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K + DOUBLE PRECISION AII +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGELQ2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = 1, K +* +* Generate elementary reflector H(i) to annihilate A(i,i+1:n) +* + CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, + $ TAU( I ) ) + IF( I.LT.M ) THEN +* +* Apply H(i) to A(i+1:m,i:n) from the right +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), + $ A( I+1, I ), LDA, WORK ) + A( I, I ) = AII + END IF + 10 CONTINUE + RETURN +* +* End of DGELQ2 +* + END diff --git a/2.3-1/src/fortran/lapack/dgelqf.f b/2.3-1/src/fortran/lapack/dgelqf.f new file mode 100644 index 00000000..063a38ba --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgelqf.f @@ -0,0 +1,195 @@ + SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DGELQ2, DLARFB, DLARFT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + LWKOPT = M*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGELQF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + K = MIN( M, N ) + IF( K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = M + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DGELQF', ' ', M, N, -1, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = M + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', M, N, -1, + $ -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code initially +* + DO 10 I = 1, K - NX, NB + IB = MIN( K-I+1, NB ) +* +* Compute the LQ factorization of the current block +* A(i:i+ib-1,i:n) +* + CALL DGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) + IF( I+IB.LE.M ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), + $ LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(i+ib:m,i:n) from the right +* + CALL DLARFB( 'Right', 'No transpose', 'Forward', + $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), + $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, + $ WORK( IB+1 ), LDWORK ) + END IF + 10 CONTINUE + ELSE + I = 1 + END IF +* +* Use unblocked code to factor the last or only block. +* + IF( I.LE.K ) + $ CALL DGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* + WORK( 1 ) = IWS + RETURN +* +* End of DGELQF +* + END diff --git a/2.3-1/src/fortran/lapack/dgels.f b/2.3-1/src/fortran/lapack/dgels.f new file mode 100644 index 00000000..4fa1e229 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgels.f @@ -0,0 +1,422 @@ + SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, + $ INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, TPSD + INTEGER BROW, I, IASCL, IBSCL, J, MN, NB, SCLLEN, WSIZE + DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM +* .. +* .. Local Arrays .. + DOUBLE PRECISION RWORK( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, ILAENV, DLABAD, DLAMCH, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL DGELQF, DGEQRF, DLASCL, DLASET, DORMLQ, DORMQR, + $ DTRTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments. +* + INFO = 0 + MN = MIN( M, N ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.MAX( 1, MN+MAX( MN, NRHS ) ) .AND. .NOT.LQUERY ) + $ THEN + INFO = -10 + END IF +* +* Figure out optimal block size +* + IF( INFO.EQ.0 .OR. INFO.EQ.-10 ) THEN +* + TPSD = .TRUE. + IF( LSAME( TRANS, 'N' ) ) + $ TPSD = .FALSE. +* + IF( M.GE.N ) THEN + NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + IF( TPSD ) THEN + NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LN', M, NRHS, N, + $ -1 ) ) + ELSE + NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, + $ -1 ) ) + END IF + ELSE + NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + IF( TPSD ) THEN + NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, + $ -1 ) ) + ELSE + NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LN', N, NRHS, M, + $ -1 ) ) + END IF + END IF +* + WSIZE = MAX( 1, MN+MAX( MN, NRHS )*NB ) + WORK( 1 ) = DBLE( WSIZE ) +* + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGELS ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N, NRHS ).EQ.0 ) THEN + CALL DLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) + RETURN + END IF +* +* Get machine parameters +* + SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* +* Scale A, B if max element outside range [SMLNUM,BIGNUM] +* + ANRM = DLANGE( 'M', M, N, A, LDA, RWORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN +* +* Matrix all zero. Return zero solution. +* + CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) + GO TO 50 + END IF +* + BROW = M + IF( TPSD ) + $ BROW = N + BNRM = DLANGE( 'M', BROW, NRHS, B, LDB, RWORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB, + $ INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB, + $ INFO ) + IBSCL = 2 + END IF +* + IF( M.GE.N ) THEN +* +* compute QR factorization of A +* + CALL DGEQRF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN, + $ INFO ) +* +* workspace at least N, optimally N*NB +* + IF( .NOT.TPSD ) THEN +* +* Least-Squares Problem min || A * X - B || +* +* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) +* + CALL DORMQR( 'Left', 'Transpose', M, NRHS, N, A, LDA, + $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, + $ INFO ) +* +* workspace at least NRHS, optimally NRHS*NB +* +* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) +* + CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', N, NRHS, + $ A, LDA, B, LDB, INFO ) +* + IF( INFO.GT.0 ) THEN + RETURN + END IF +* + SCLLEN = N +* + ELSE +* +* Overdetermined system of equations A' * X = B +* +* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) +* + CALL DTRTRS( 'Upper', 'Transpose', 'Non-unit', N, NRHS, + $ A, LDA, B, LDB, INFO ) +* + IF( INFO.GT.0 ) THEN + RETURN + END IF +* +* B(N+1:M,1:NRHS) = ZERO +* + DO 20 J = 1, NRHS + DO 10 I = N + 1, M + B( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE +* +* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) +* + CALL DORMQR( 'Left', 'No transpose', M, NRHS, N, A, LDA, + $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, + $ INFO ) +* +* workspace at least NRHS, optimally NRHS*NB +* + SCLLEN = M +* + END IF +* + ELSE +* +* Compute LQ factorization of A +* + CALL DGELQF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN, + $ INFO ) +* +* workspace at least M, optimally M*NB. +* + IF( .NOT.TPSD ) THEN +* +* underdetermined system of equations A * X = B +* +* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) +* + CALL DTRTRS( 'Lower', 'No transpose', 'Non-unit', M, NRHS, + $ A, LDA, B, LDB, INFO ) +* + IF( INFO.GT.0 ) THEN + RETURN + END IF +* +* B(M+1:N,1:NRHS) = 0 +* + DO 40 J = 1, NRHS + DO 30 I = M + 1, N + B( I, J ) = ZERO + 30 CONTINUE + 40 CONTINUE +* +* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) +* + CALL DORMLQ( 'Left', 'Transpose', N, NRHS, M, A, LDA, + $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, + $ 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) +* + CALL DORMLQ( 'Left', 'No transpose', N, NRHS, M, A, LDA, + $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, + $ INFO ) +* +* workspace at least NRHS, optimally NRHS*NB +* +* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) +* + CALL DTRTRS( 'Lower', 'Transpose', 'Non-unit', M, NRHS, + $ A, LDA, B, LDB, INFO ) +* + IF( INFO.GT.0 ) THEN + RETURN + END IF +* + SCLLEN = M +* + END IF +* + END IF +* +* Undo scaling +* + IF( IASCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB, + $ INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB, + $ INFO ) + END IF + IF( IBSCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB, + $ INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB, + $ INFO ) + END IF +* + 50 CONTINUE + WORK( 1 ) = DBLE( WSIZE ) +* + RETURN +* +* End of DGELS +* + END diff --git a/2.3-1/src/fortran/lapack/dgelss.f b/2.3-1/src/fortran/lapack/dgelss.f new file mode 100644 index 00000000..f024e138 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgelss.f @@ -0,0 +1,617 @@ + SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, + $ WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER BDSPAC, BL, CHUNK, I, IASCL, IBSCL, IE, IL, + $ ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN, + $ MAXWRK, MINMN, MINWRK, MM, MNTHR + DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR +* .. +* .. Local Arrays .. + DOUBLE PRECISION VDUM( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DBDSQR, DCOPY, DGEBRD, DGELQF, DGEMM, DGEMV, + $ DGEQRF, DLABAD, DLACPY, DLASCL, DLASET, DORGBR, + $ DORMBR, DORMLQ, DORMQR, DRSCL, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL ILAENV, DLAMCH, DLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + MINMN = MIN( M, N ) + MAXMN = MAX( M, N ) + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN + INFO = -7 + END IF +* +* 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.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + IF( MINMN.GT.0 ) THEN + MM = M + MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -1 ) + IF( M.GE.N .AND. M.GE.MNTHR ) THEN +* +* Path 1a - overdetermined, with many more rows than +* columns +* + MM = N + MAXWRK = MAX( MAXWRK, N + N*ILAENV( 1, 'DGEQRF', ' ', M, + $ N, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, N + NRHS*ILAENV( 1, 'DORMQR', 'LT', + $ M, NRHS, N, -1 ) ) + END IF + IF( M.GE.N ) THEN +* +* Path 1 - overdetermined or exactly determined +* +* Compute workspace needed for DBDSQR +* + BDSPAC = MAX( 1, 5*N ) + MAXWRK = MAX( MAXWRK, 3*N + ( MM + N )*ILAENV( 1, + $ 'DGEBRD', ' ', MM, N, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*N + NRHS*ILAENV( 1, 'DORMBR', + $ 'QLT', MM, NRHS, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*N + ( N - 1 )*ILAENV( 1, + $ 'DORGBR', 'P', N, N, N, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC ) + MAXWRK = MAX( MAXWRK, N*NRHS ) + MINWRK = MAX( 3*N + MM, 3*N + NRHS, BDSPAC ) + MAXWRK = MAX( MINWRK, MAXWRK ) + END IF + IF( N.GT.M ) THEN +* +* Compute workspace needed for DBDSQR +* + BDSPAC = MAX( 1, 5*M ) + MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC ) + IF( N.GE.MNTHR ) THEN +* +* Path 2a - underdetermined, with many more columns +* than rows +* + MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, + $ -1 ) + MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1, + $ 'DGEBRD', ' ', M, M, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1, + $ 'DORMBR', 'QLT', M, NRHS, M, -1 ) ) + MAXWRK = MAX( MAXWRK, M*M + 4*M + + $ ( M - 1 )*ILAENV( 1, 'DORGBR', 'P', M, + $ M, M, -1 ) ) + MAXWRK = MAX( MAXWRK, M*M + M + BDSPAC ) + IF( NRHS.GT.1 ) THEN + MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS ) + ELSE + MAXWRK = MAX( MAXWRK, M*M + 2*M ) + END IF + MAXWRK = MAX( MAXWRK, M + NRHS*ILAENV( 1, 'DORMLQ', + $ 'LT', N, NRHS, M, -1 ) ) + ELSE +* +* Path 2 - underdetermined +* + MAXWRK = 3*M + ( N + M )*ILAENV( 1, 'DGEBRD', ' ', M, + $ N, -1, -1 ) + MAXWRK = MAX( MAXWRK, 3*M + NRHS*ILAENV( 1, 'DORMBR', + $ 'QLT', M, NRHS, M, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*M + M*ILAENV( 1, 'DORGBR', + $ 'P', M, N, M, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC ) + MAXWRK = MAX( MAXWRK, N*NRHS ) + END IF + END IF + MAXWRK = MAX( MINWRK, MAXWRK ) + END IF + WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -12 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGELSS', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + RANK = 0 + RETURN + END IF +* +* Get machine parameters +* + EPS = DLAMCH( 'P' ) + SFMIN = DLAMCH( 'S' ) + SMLNUM = SFMIN / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = DLANGE( 'M', M, N, A, LDA, WORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN +* +* Matrix all zero. Return zero solution. +* + CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) + CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 ) + RANK = 0 + GO TO 70 + END IF +* +* Scale B if max element outside range [SMLNUM,BIGNUM] +* + BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) + IBSCL = 2 + END IF +* +* Overdetermined case +* + IF( M.GE.N ) THEN +* +* Path 1 - overdetermined or exactly determined +* + MM = M + IF( M.GE.MNTHR ) THEN +* +* 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) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), + $ LWORK-IWORK+1, INFO ) +* +* Multiply B by transpose(Q) +* (Workspace: need N+NRHS, prefer N+NRHS*NB) +* + CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B, + $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) +* +* Zero out below R +* + IF( N.GT.1 ) + $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) + END IF +* + 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) +* + CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, + $ INFO ) +* +* Multiply B by transpose of left bidiagonalizing vectors of R +* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) +* + CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ), + $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) +* +* Generate right bidiagonalizing vectors of R in A +* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* + CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+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) +* + CALL DBDSQR( 'U', N, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM, + $ 1, B, LDB, WORK( IWORK ), INFO ) + IF( INFO.NE.0 ) + $ GO TO 70 +* +* Multiply B by reciprocals of singular values +* + THR = MAX( RCOND*S( 1 ), SFMIN ) + IF( RCOND.LT.ZERO ) + $ THR = MAX( EPS*S( 1 ), SFMIN ) + RANK = 0 + DO 10 I = 1, N + IF( S( I ).GT.THR ) THEN + CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) + RANK = RANK + 1 + ELSE + CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) + END IF + 10 CONTINUE +* +* Multiply B by right singular vectors +* (Workspace: need N, prefer N*NRHS) +* + IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN + CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, A, LDA, B, LDB, ZERO, + $ WORK, LDB ) + CALL DLACPY( 'G', N, NRHS, WORK, LDB, B, LDB ) + ELSE IF( NRHS.GT.1 ) THEN + CHUNK = LWORK / N + DO 20 I = 1, NRHS, CHUNK + BL = MIN( NRHS-I+1, CHUNK ) + CALL DGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B( 1, I ), + $ LDB, ZERO, WORK, N ) + CALL DLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB ) + 20 CONTINUE + ELSE + CALL DGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 ) + CALL DCOPY( N, WORK, 1, B, 1 ) + END IF +* + ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+ + $ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN +* +* Path 2a - underdetermined, with many more columns than rows +* and sufficient workspace for an efficient algorithm +* + LDWORK = M + IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ), + $ M*LDA+M+M*NRHS ) )LDWORK = LDA + ITAU = 1 + IWORK = M + 1 +* +* Compute A=L*Q +* (Workspace: need 2*M, prefer M+M*NB) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), + $ LWORK-IWORK+1, INFO ) + IL = IWORK +* +* Copy L to WORK(IL), zeroing out above it +* + CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, 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) +* + CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+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) +* + CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK, + $ WORK( ITAUQ ), B, LDB, WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL DORGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', M, M, 0, NRHS, S, WORK( IE ), WORK( IL ), + $ LDWORK, A, LDA, B, LDB, WORK( IWORK ), INFO ) + IF( INFO.NE.0 ) + $ GO TO 70 +* +* Multiply B by reciprocals of singular values +* + THR = MAX( RCOND*S( 1 ), SFMIN ) + IF( RCOND.LT.ZERO ) + $ THR = MAX( EPS*S( 1 ), SFMIN ) + RANK = 0 + DO 30 I = 1, M + IF( S( I ).GT.THR ) THEN + CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) + RANK = RANK + 1 + ELSE + CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) + END IF + 30 CONTINUE + 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.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN + CALL DGEMM( 'T', 'N', M, NRHS, M, ONE, WORK( IL ), LDWORK, + $ B, LDB, ZERO, WORK( IWORK ), LDB ) + CALL DLACPY( 'G', M, NRHS, WORK( IWORK ), LDB, B, LDB ) + ELSE IF( NRHS.GT.1 ) THEN + CHUNK = ( LWORK-IWORK+1 ) / M + DO 40 I = 1, NRHS, CHUNK + BL = MIN( NRHS-I+1, CHUNK ) + CALL DGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK, + $ B( 1, I ), LDB, ZERO, WORK( IWORK ), M ) + CALL DLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ), + $ LDB ) + 40 CONTINUE + ELSE + CALL DGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ), + $ 1, ZERO, WORK( IWORK ), 1 ) + CALL DCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 ) + END IF +* +* Zero out below first M rows of B +* + CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) + IWORK = ITAU + M +* +* Multiply transpose(Q) by B +* (Workspace: need M+NRHS, prefer M+NRHS*NB) +* + CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B, + $ LDB, WORK( IWORK ), LWORK-IWORK+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) +* + CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, + $ INFO ) +* +* Multiply B by transpose of left bidiagonalizing vectors +* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) +* + CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ), + $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) +* +* Generate right bidiagonalizing vectors in A +* (Workspace: need 4*M, prefer 3*M+M*NB) +* + CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+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) +* + CALL DBDSQR( 'L', M, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM, + $ 1, B, LDB, WORK( IWORK ), INFO ) + IF( INFO.NE.0 ) + $ GO TO 70 +* +* Multiply B by reciprocals of singular values +* + THR = MAX( RCOND*S( 1 ), SFMIN ) + IF( RCOND.LT.ZERO ) + $ THR = MAX( EPS*S( 1 ), SFMIN ) + RANK = 0 + DO 50 I = 1, M + IF( S( I ).GT.THR ) THEN + CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) + RANK = RANK + 1 + ELSE + CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) + END IF + 50 CONTINUE +* +* Multiply B by right singular vectors of A +* (Workspace: need N, prefer N*NRHS) +* + IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN + CALL DGEMM( 'T', 'N', N, NRHS, M, ONE, A, LDA, B, LDB, ZERO, + $ WORK, LDB ) + CALL DLACPY( 'F', N, NRHS, WORK, LDB, B, LDB ) + ELSE IF( NRHS.GT.1 ) THEN + CHUNK = LWORK / N + DO 60 I = 1, NRHS, CHUNK + BL = MIN( NRHS-I+1, CHUNK ) + CALL DGEMM( 'T', 'N', N, BL, M, ONE, A, LDA, B( 1, I ), + $ LDB, ZERO, WORK, N ) + CALL DLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB ) + 60 CONTINUE + ELSE + CALL DGEMV( 'T', M, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 ) + CALL DCOPY( N, WORK, 1, B, 1 ) + END IF + END IF +* +* Undo scaling +* + IF( IASCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) + CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, + $ INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) + CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, + $ INFO ) + END IF + IF( IBSCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) + END IF +* + 70 CONTINUE + WORK( 1 ) = MAXWRK + RETURN +* +* End of DGELSS +* + END diff --git a/2.3-1/src/fortran/lapack/dgelsx.f b/2.3-1/src/fortran/lapack/dgelsx.f new file mode 100644 index 00000000..a597cd47 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgelsx.f @@ -0,0 +1,349 @@ + SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, + $ WORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, M, N, NRHS, RANK + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* 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 .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ZERO, ONE, DONE, NTDONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, DONE = ZERO, + $ NTDONE = ONE ) +* .. +* .. Local Scalars .. + INTEGER I, IASCL, IBSCL, ISMAX, ISMIN, J, K, MN + DOUBLE PRECISION ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX, + $ SMAXPR, SMIN, SMINPR, SMLNUM, T1, T2 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL DGEQPF, DLAIC1, DLASCL, DLASET, DLATZM, DORM2R, + $ DTRSM, DTZRQF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + MN = MIN( M, N ) + ISMIN = MN + 1 + ISMAX = 2*MN + 1 +* +* Test the input arguments. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN + INFO = -7 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGELSX', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N, NRHS ).EQ.0 ) THEN + RANK = 0 + RETURN + END IF +* +* Get machine parameters +* + SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* +* Scale A, B if max elements outside range [SMLNUM,BIGNUM] +* + ANRM = DLANGE( 'M', M, N, A, LDA, WORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN +* +* Matrix all zero. Return zero solution. +* + CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) + RANK = 0 + GO TO 100 + END IF +* + BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) + IBSCL = 2 + END IF +* +* Compute QR factorization with column pivoting of A: +* A * P = Q * R +* + CALL DGEQPF( M, N, A, LDA, JPVT, 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 ) = ONE + WORK( ISMAX ) = ONE + SMAX = ABS( A( 1, 1 ) ) + SMIN = SMAX + IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN + RANK = 0 + CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) + GO TO 100 + ELSE + RANK = 1 + END IF +* + 10 CONTINUE + IF( RANK.LT.MN ) THEN + I = RANK + 1 + CALL DLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ), + $ A( I, I ), SMINPR, S1, C1 ) + CALL DLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ), + $ A( I, I ), SMAXPR, S2, C2 ) +* + IF( SMAXPR*RCOND.LE.SMINPR ) THEN + DO 20 I = 1, RANK + WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 ) + WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 ) + 20 CONTINUE + WORK( ISMIN+RANK ) = C1 + WORK( ISMAX+RANK ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 10 + END IF + END IF +* +* Logically partition R = [ R11 R12 ] +* [ 0 R22 ] +* where R11 = R(1:RANK,1:RANK) +* +* [R11,R12] = [ T11, 0 ] * Y +* + IF( RANK.LT.N ) + $ CALL DTZRQF( RANK, N, A, 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) +* + CALL DORM2R( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ), + $ B, LDB, WORK( 2*MN+1 ), INFO ) +* +* workspace NRHS +* +* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) +* + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, + $ NRHS, ONE, A, LDA, B, LDB ) +* + DO 40 I = RANK + 1, N + DO 30 J = 1, NRHS + B( I, J ) = ZERO + 30 CONTINUE + 40 CONTINUE +* +* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) +* + IF( RANK.LT.N ) THEN + DO 50 I = 1, RANK + CALL DLATZM( 'Left', N-RANK+1, NRHS, A( I, RANK+1 ), LDA, + $ WORK( MN+I ), B( I, 1 ), B( RANK+1, 1 ), LDB, + $ WORK( 2*MN+1 ) ) + 50 CONTINUE + END IF +* +* workspace NRHS +* +* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) +* + DO 90 J = 1, NRHS + DO 60 I = 1, N + WORK( 2*MN+I ) = NTDONE + 60 CONTINUE + DO 80 I = 1, N + IF( WORK( 2*MN+I ).EQ.NTDONE ) THEN + IF( JPVT( I ).NE.I ) THEN + K = I + T1 = B( K, J ) + T2 = B( JPVT( K ), J ) + 70 CONTINUE + B( JPVT( K ), J ) = T1 + WORK( 2*MN+K ) = DONE + T1 = T2 + K = JPVT( K ) + T2 = B( JPVT( K ), J ) + IF( JPVT( K ).NE.I ) + $ GO TO 70 + B( I, J ) = T1 + WORK( 2*MN+K ) = DONE + END IF + END IF + 80 CONTINUE + 90 CONTINUE +* +* Undo scaling +* + IF( IASCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) + CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA, + $ INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) + CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA, + $ INFO ) + END IF + IF( IBSCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) + END IF +* + 100 CONTINUE +* + RETURN +* +* End of DGELSX +* + END diff --git a/2.3-1/src/fortran/lapack/dgelsy.f b/2.3-1/src/fortran/lapack/dgelsy.f new file mode 100644 index 00000000..4334650f --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgelsy.f @@ -0,0 +1,391 @@ + SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, + $ WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* 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 .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IASCL, IBSCL, ISMAX, ISMIN, J, LWKMIN, + $ LWKOPT, MN, NB, NB1, NB2, NB3, NB4 + DOUBLE PRECISION ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX, + $ SMAXPR, SMIN, SMINPR, SMLNUM, WSIZE +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL ILAENV, DLAMCH, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEQP3, DLABAD, DLAIC1, DLASCL, DLASET, + $ DORMQR, DORMRZ, DTRSM, DTZRZF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + MN = MIN( M, N ) + ISMIN = MN + 1 + ISMAX = 2*MN + 1 +* +* Test the input arguments. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN + INFO = -7 + END IF +* +* Figure out optimal block size +* + IF( INFO.EQ.0 ) THEN + IF( MN.EQ.0 .OR. NRHS.EQ.0 ) THEN + LWKMIN = 1 + LWKOPT = 1 + ELSE + NB1 = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + NB2 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 ) + NB3 = ILAENV( 1, 'DORMQR', ' ', M, N, NRHS, -1 ) + NB4 = ILAENV( 1, 'DORMRQ', ' ', M, N, NRHS, -1 ) + NB = MAX( NB1, NB2, NB3, NB4 ) + LWKMIN = MN + MAX( 2*MN, N + 1, MN + NRHS ) + LWKOPT = MAX( LWKMIN, + $ MN + 2*N + NB*( N + 1 ), 2*MN + NB*NRHS ) + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGELSY', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MN.EQ.0 .OR. NRHS.EQ.0 ) THEN + RANK = 0 + RETURN + END IF +* +* Get machine parameters +* + SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* +* Scale A, B if max entries outside range [SMLNUM,BIGNUM] +* + ANRM = DLANGE( 'M', M, N, A, LDA, WORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN +* +* Matrix all zero. Return zero solution. +* + CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) + RANK = 0 + GO TO 70 + END IF +* + BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) + IBSCL = 2 + END IF +* +* Compute QR factorization with column pivoting of A: +* A * P = Q * R +* + CALL DGEQP3( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ), + $ LWORK-MN, 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 ) = ONE + WORK( ISMAX ) = ONE + SMAX = ABS( A( 1, 1 ) ) + SMIN = SMAX + IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN + RANK = 0 + CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) + GO TO 70 + ELSE + RANK = 1 + END IF +* + 10 CONTINUE + IF( RANK.LT.MN ) THEN + I = RANK + 1 + CALL DLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ), + $ A( I, I ), SMINPR, S1, C1 ) + CALL DLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ), + $ A( I, I ), SMAXPR, S2, C2 ) +* + IF( SMAXPR*RCOND.LE.SMINPR ) THEN + DO 20 I = 1, RANK + WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 ) + WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 ) + 20 CONTINUE + WORK( ISMIN+RANK ) = C1 + WORK( ISMAX+RANK ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 10 + END IF + END IF +* +* workspace: 3*MN. +* +* Logically partition R = [ R11 R12 ] +* [ 0 R22 ] +* where R11 = R(1:RANK,1:RANK) +* +* [R11,R12] = [ T11, 0 ] * Y +* + IF( RANK.LT.N ) + $ CALL DTZRZF( RANK, N, A, LDA, WORK( MN+1 ), WORK( 2*MN+1 ), + $ LWORK-2*MN, 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) +* + CALL DORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ), + $ B, LDB, WORK( 2*MN+1 ), LWORK-2*MN, INFO ) + WSIZE = MAX( WSIZE, 2*MN+WORK( 2*MN+1 ) ) +* +* workspace: 2*MN+NB*NRHS. +* +* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) +* + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, + $ NRHS, ONE, A, LDA, B, LDB ) +* + DO 40 J = 1, NRHS + DO 30 I = RANK + 1, N + B( I, J ) = ZERO + 30 CONTINUE + 40 CONTINUE +* +* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) +* + IF( RANK.LT.N ) THEN + CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A, + $ LDA, WORK( MN+1 ), B, LDB, WORK( 2*MN+1 ), + $ LWORK-2*MN, INFO ) + END IF +* +* workspace: 2*MN+NRHS. +* +* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) +* + DO 60 J = 1, NRHS + DO 50 I = 1, N + WORK( JPVT( I ) ) = B( I, J ) + 50 CONTINUE + CALL DCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 ) + 60 CONTINUE +* +* workspace: N. +* +* Undo scaling +* + IF( IASCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) + CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA, + $ INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) + CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA, + $ INFO ) + END IF + IF( IBSCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) + END IF +* + 70 CONTINUE + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DGELSY +* + END diff --git a/2.3-1/src/fortran/lapack/dgeql2.f b/2.3-1/src/fortran/lapack/dgeql2.f new file mode 100644 index 00000000..aa45113c --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgeql2.f @@ -0,0 +1,122 @@ + SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K + DOUBLE PRECISION AII +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQL2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = K, 1, -1 +* +* Generate elementary reflector H(i) to annihilate +* A(1:m-k+i-1,n-k+i) +* + CALL DLARFG( M-K+I, A( M-K+I, N-K+I ), A( 1, N-K+I ), 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( M-K+I, N-K+I ) = ONE + CALL DLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, TAU( I ), + $ A, LDA, WORK ) + A( M-K+I, N-K+I ) = AII + 10 CONTINUE + RETURN +* +* End of DGEQL2 +* + END diff --git a/2.3-1/src/fortran/lapack/dgeqlf.f b/2.3-1/src/fortran/lapack/dgeqlf.f new file mode 100644 index 00000000..ec293574 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgeqlf.f @@ -0,0 +1,213 @@ + SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT, + $ MU, NB, NBMIN, NU, NX +* .. +* .. External Subroutines .. + EXTERNAL DGEQL2, DLARFB, DLARFT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF +* + IF( INFO.EQ.0 ) THEN + K = MIN( M, N ) + IF( K.EQ.0 ) THEN + LWKOPT = 1 + ELSE + NB = ILAENV( 1, 'DGEQLF', ' ', M, N, -1, -1 ) + LWKOPT = N*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQLF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( K.EQ.0 ) THEN + RETURN + END IF +* + NBMIN = 2 + NX = 1 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DGEQLF', ' ', M, N, -1, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DGEQLF', ' ', M, N, -1, + $ -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code initially. +* The last kk columns are handled by the block method. +* + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) +* + DO 10 I = K - KK + KI + 1, K - KK + 1, -NB + IB = MIN( K-I+1, NB ) +* +* Compute the QL factorization of the current block +* A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1) +* + CALL DGEQL2( M-K+I+IB-1, IB, A( 1, N-K+I ), LDA, TAU( I ), + $ WORK, IINFO ) + IF( N-K+I.GT.1 ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i+ib-1) . . . H(i+1) H(i) +* + CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, + $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H' to A(1:m-k+i+ib-1,1:n-k+i-1) from the left +* + CALL DLARFB( 'Left', 'Transpose', 'Backward', + $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, + $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, + $ WORK( IB+1 ), LDWORK ) + END IF + 10 CONTINUE + MU = M - K + I + NB - 1 + NU = N - K + I + NB - 1 + ELSE + MU = M + NU = N + END IF +* +* Use unblocked code to factor the last or only block +* + IF( MU.GT.0 .AND. NU.GT.0 ) + $ CALL DGEQL2( MU, NU, A, LDA, TAU, WORK, IINFO ) +* + WORK( 1 ) = IWS + RETURN +* +* End of DGEQLF +* + END diff --git a/2.3-1/src/fortran/lapack/dgeqp3.f b/2.3-1/src/fortran/lapack/dgeqp3.f new file mode 100644 index 00000000..d6bc537d --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgeqp3.f @@ -0,0 +1,287 @@ + SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + INTEGER INB, INBMIN, IXOVER + PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, + $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN +* .. +* .. External Subroutines .. + EXTERNAL DGEQRF, DLAQP2, DLAQPS, DORMQR, DSWAP, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DNRM2 + EXTERNAL ILAENV, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE + IWS = 3*N + 1 + NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = 2*N + ( N + 1 )*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQP3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible. +* + IF( MINMN.EQ.0 ) THEN + RETURN + END IF +* +* Move initial columns up front. +* + NFXD = 1 + DO 10 J = 1, N + IF( JPVT( J ).NE.0 ) THEN + IF( J.NE.NFXD ) THEN + CALL DSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 ) + JPVT( J ) = JPVT( NFXD ) + JPVT( NFXD ) = J + ELSE + JPVT( J ) = J + END IF + NFXD = NFXD + 1 + ELSE + JPVT( J ) = J + END IF + 10 CONTINUE + NFXD = NFXD - 1 +* +* Factorize fixed columns +* ======================= +* +* Compute the QR factorization of fixed columns and update +* remaining columns. +* + IF( NFXD.GT.0 ) THEN + NA = MIN( M, NFXD ) +*CC CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) + CALL DGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO ) + IWS = MAX( IWS, INT( WORK( 1 ) ) ) + IF( NA.LT.N ) THEN +*CC CALL DORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA, +*CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) + CALL DORMQR( 'Left', 'Transpose', M, N-NA, NA, A, LDA, TAU, + $ A( 1, NA+1 ), LDA, WORK, LWORK, INFO ) + IWS = MAX( IWS, INT( WORK( 1 ) ) ) + END IF + END IF +* +* Factorize free columns +* ====================== +* + IF( NFXD.LT.MINMN ) THEN +* + SM = M - NFXD + SN = N - NFXD + SMINMN = MINMN - NFXD +* +* Determine the block size. +* + NB = ILAENV( INB, 'DGEQRF', ' ', SM, SN, -1, -1 ) + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', SM, SN, -1, + $ -1 ) ) +* +* + IF( NX.LT.SMINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + MINWS = 2*SN + ( SN+1 )*NB + IWS = MAX( IWS, MINWS ) + IF( LWORK.LT.MINWS ) THEN +* +* Not enough workspace to use optimal NB: Reduce NB and +* determine the minimum value of NB. +* + NB = ( LWORK-2*SN ) / ( SN+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', SM, SN, + $ -1, -1 ) ) +* +* + END IF + END IF + END IF +* +* Initialize partial column norms. The first N elements of work +* store the exact column norms. +* + DO 20 J = NFXD + 1, N + WORK( J ) = DNRM2( SM, A( NFXD+1, J ), 1 ) + WORK( N+J ) = WORK( J ) + 20 CONTINUE +* + IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. + $ ( NX.LT.SMINMN ) ) THEN +* +* Use blocked code initially. +* + J = NFXD + 1 +* +* Compute factorization: while loop. +* +* + TOPBMN = MINMN - NX + 30 CONTINUE + IF( J.LE.TOPBMN ) THEN + JB = MIN( NB, TOPBMN-J+1 ) +* +* Factorize JB columns among columns J:N. +* + CALL DLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, + $ JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 ) +* + J = J + FJB + GO TO 30 + END IF + ELSE + J = NFXD + 1 + END IF +* +* Use unblocked code to factor the last or only block. +* +* + IF( J.LE.MINMN ) + $ CALL DLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), + $ TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ) ) +* + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of DGEQP3 +* + END diff --git a/2.3-1/src/fortran/lapack/dgeqpf.f b/2.3-1/src/fortran/lapack/dgeqpf.f new file mode 100644 index 00000000..1b7acd6d --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgeqpf.f @@ -0,0 +1,231 @@ + SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) +* +* -- LAPACK deprecated driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, MA, MN, PVT + DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DGEQR2, DLARF, DLARFG, DORM2R, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQPF', -INFO ) + RETURN + END IF +* + MN = MIN( M, N ) + TOL3Z = SQRT(DLAMCH('Epsilon')) +* +* Move initial columns up front +* + ITEMP = 1 + DO 10 I = 1, N + IF( JPVT( I ).NE.0 ) THEN + IF( I.NE.ITEMP ) THEN + CALL DSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 ) + JPVT( I ) = JPVT( ITEMP ) + JPVT( ITEMP ) = I + ELSE + JPVT( I ) = I + END IF + ITEMP = ITEMP + 1 + ELSE + JPVT( I ) = I + END IF + 10 CONTINUE + ITEMP = ITEMP - 1 +* +* Compute the QR factorization and update remaining columns +* + IF( ITEMP.GT.0 ) THEN + MA = MIN( ITEMP, M ) + CALL DGEQR2( M, MA, A, LDA, TAU, WORK, INFO ) + IF( MA.LT.N ) THEN + CALL DORM2R( 'Left', 'Transpose', M, N-MA, MA, A, LDA, TAU, + $ A( 1, MA+1 ), LDA, WORK, INFO ) + END IF + END IF +* + IF( ITEMP.LT.MN ) THEN +* +* Initialize partial column norms. The first n elements of +* work store the exact column norms. +* + DO 20 I = ITEMP + 1, N + WORK( I ) = DNRM2( M-ITEMP, A( ITEMP+1, I ), 1 ) + WORK( N+I ) = WORK( I ) + 20 CONTINUE +* +* Compute factorization +* + DO 40 I = ITEMP + 1, MN +* +* Determine ith pivot column and swap if necessary +* + PVT = ( I-1 ) + IDAMAX( N-I+1, WORK( I ), 1 ) +* + IF( PVT.NE.I ) THEN + CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( I ) + JPVT( I ) = ITEMP + WORK( PVT ) = WORK( I ) + WORK( N+PVT ) = WORK( N+I ) + END IF +* +* Generate elementary reflector H(i) +* + IF( I.LT.M ) THEN + CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) + ELSE + CALL DLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) ) + END IF +* + IF( I.LT.N ) THEN +* +* Apply H(i) to A(i:m,i+1:n) from the left +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK( 2*N+1 ) ) + A( I, I ) = AII + END IF +* +* Update partial column norms +* + DO 30 J = I + 1, N + IF( WORK( J ).NE.ZERO ) THEN +* +* NOTE: The following 4 lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ABS( A( I, J ) ) / WORK( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( WORK( J ) / WORK( N+J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN + IF( M-I.GT.0 ) THEN + WORK( J ) = DNRM2( M-I, A( I+1, J ), 1 ) + WORK( N+J ) = WORK( J ) + ELSE + WORK( J ) = ZERO + WORK( N+J ) = ZERO + END IF + ELSE + WORK( J ) = WORK( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE +* + 40 CONTINUE + END IF + RETURN +* +* End of DGEQPF +* + END diff --git a/2.3-1/src/fortran/lapack/dgeqr2.f b/2.3-1/src/fortran/lapack/dgeqr2.f new file mode 100644 index 00000000..9872a162 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgeqr2.f @@ -0,0 +1,121 @@ + SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K + DOUBLE PRECISION AII +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQR2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = 1, K +* +* Generate elementary reflector H(i) to annihilate A(i+1:m,i) +* + CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, + $ TAU( I ) ) + IF( I.LT.N ) THEN +* +* Apply H(i) to A(i:m,i+1:n) from the left +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + A( I, I ) = AII + END IF + 10 CONTINUE + RETURN +* +* End of DGEQR2 +* + END diff --git a/2.3-1/src/fortran/lapack/dgeqrf.f b/2.3-1/src/fortran/lapack/dgeqrf.f new file mode 100644 index 00000000..1e940597 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgeqrf.f @@ -0,0 +1,196 @@ + SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQRF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + K = MIN( M, N ) + IF( K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, + $ -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code initially +* + DO 10 I = 1, K - NX, NB + IB = MIN( K-I+1, NB ) +* +* Compute the QR factorization of the current block +* A(i:m,i:i+ib-1) +* + CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) + IF( I+IB.LE.N ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, + $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H' to A(i:m,i+ib:n) from the left +* + CALL DLARFB( 'Left', 'Transpose', 'Forward', + $ 'Columnwise', M-I+1, N-I-IB+1, IB, + $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), + $ LDA, WORK( IB+1 ), LDWORK ) + END IF + 10 CONTINUE + ELSE + I = 1 + END IF +* +* Use unblocked code to factor the last or only block. +* + IF( I.LE.K ) + $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* + WORK( 1 ) = IWS + RETURN +* +* End of DGEQRF +* + END diff --git a/2.3-1/src/fortran/lapack/dgerfs.f b/2.3-1/src/fortran/lapack/dgerfs.f new file mode 100644 index 00000000..bada6e56 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgerfs.f @@ -0,0 +1,336 @@ + SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, + $ X, LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* 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 .. + CHARACTER TRANS + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* 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 .. + INTEGER ITMAX + PARAMETER ( ITMAX = 5 ) + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D+0 ) + DOUBLE PRECISION THREE + PARAMETER ( THREE = 3.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN + CHARACTER TRANST + INTEGER COUNT, I, J, K, KASE, NZ + DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGETRS, DLACN2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -12 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGERFS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + DO 10 J = 1, NRHS + FERR( J ) = ZERO + BERR( J ) = ZERO + 10 CONTINUE + RETURN + END IF +* + IF( NOTRAN ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* +* 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 +* + DO 140 J = 1, NRHS +* + COUNT = 1 + LSTRES = THREE + 20 CONTINUE +* +* 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. +* + CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) + CALL DGEMV( TRANS, N, N, -ONE, A, LDA, X( 1, J ), 1, ONE, + $ WORK( N+1 ), 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. +* + DO 30 I = 1, N + WORK( I ) = ABS( B( I, J ) ) + 30 CONTINUE +* +* Compute abs(op(A))*abs(X) + abs(B). +* + IF( NOTRAN ) THEN + DO 50 K = 1, N + XK = ABS( X( K, J ) ) + DO 40 I = 1, N + WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK + 40 CONTINUE + 50 CONTINUE + ELSE + DO 70 K = 1, N + S = ZERO + DO 60 I = 1, N + S = S + ABS( A( I, K ) )*ABS( X( I, J ) ) + 60 CONTINUE + WORK( K ) = WORK( K ) + S + 70 CONTINUE + END IF + S = ZERO + DO 80 I = 1, N + IF( WORK( I ).GT.SAFE2 ) THEN + S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) ) + ELSE + S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / + $ ( WORK( I )+SAFE1 ) ) + END IF + 80 CONTINUE + 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 ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. + $ COUNT.LE.ITMAX ) THEN +* +* Update solution and try again. +* + CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N, + $ INFO ) + CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 ) + LSTRES = BERR( J ) + COUNT = COUNT + 1 + GO TO 20 + END IF +* +* 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) ))) +* + DO 90 I = 1, N + IF( WORK( I ).GT.SAFE2 ) THEN + WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + ELSE + WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1 + END IF + 90 CONTINUE +* + KASE = 0 + 100 CONTINUE + CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), + $ KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN +* +* Multiply by diag(W)*inv(op(A)**T). +* + CALL DGETRS( TRANST, N, 1, AF, LDAF, IPIV, WORK( N+1 ), + $ N, INFO ) + DO 110 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 110 CONTINUE + ELSE +* +* Multiply by inv(op(A))*diag(W). +* + DO 120 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 120 CONTINUE + CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N, + $ INFO ) + END IF + GO TO 100 + END IF +* +* Normalize error. +* + LSTRES = ZERO + DO 130 I = 1, N + LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) + 130 CONTINUE + IF( LSTRES.NE.ZERO ) + $ FERR( J ) = FERR( J ) / LSTRES +* + 140 CONTINUE +* + RETURN +* +* End of DGERFS +* + END diff --git a/2.3-1/src/fortran/lapack/dgerq2.f b/2.3-1/src/fortran/lapack/dgerq2.f new file mode 100644 index 00000000..4dfe8b0f --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgerq2.f @@ -0,0 +1,122 @@ + SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K + DOUBLE PRECISION AII +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGERQ2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = K, 1, -1 +* +* Generate elementary reflector H(i) to annihilate +* A(m-k+i,1:n-k+i-1) +* + CALL DLARFG( N-K+I, A( M-K+I, N-K+I ), A( M-K+I, 1 ), LDA, + $ TAU( I ) ) +* +* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right +* + AII = A( M-K+I, N-K+I ) + A( M-K+I, N-K+I ) = ONE + CALL DLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA, + $ TAU( I ), A, LDA, WORK ) + A( M-K+I, N-K+I ) = AII + 10 CONTINUE + RETURN +* +* End of DGERQ2 +* + END diff --git a/2.3-1/src/fortran/lapack/dgerqf.f b/2.3-1/src/fortran/lapack/dgerqf.f new file mode 100644 index 00000000..3dc22652 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgerqf.f @@ -0,0 +1,213 @@ + SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT, + $ MU, NB, NBMIN, NU, NX +* .. +* .. External Subroutines .. + EXTERNAL DGERQ2, DLARFB, DLARFT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF +* + IF( INFO.EQ.0 ) THEN + K = MIN( M, N ) + IF( K.EQ.0 ) THEN + LWKOPT = 1 + ELSE + NB = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 ) + LWKOPT = M*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGERQF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( K.EQ.0 ) THEN + RETURN + END IF +* + NBMIN = 2 + NX = 1 + IWS = M + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DGERQF', ' ', M, N, -1, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = M + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DGERQF', ' ', M, N, -1, + $ -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code initially. +* The last kk rows are handled by the block method. +* + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) +* + DO 10 I = K - KK + KI + 1, K - KK + 1, -NB + IB = MIN( K-I+1, NB ) +* +* Compute the RQ factorization of the current block +* A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1) +* + CALL DGERQ2( IB, N-K+I+IB-1, A( M-K+I, 1 ), LDA, TAU( I ), + $ WORK, IINFO ) + IF( M-K+I.GT.1 ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i+ib-1) . . . H(i+1) H(i) +* + CALL DLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB, + $ A( M-K+I, 1 ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right +* + CALL DLARFB( 'Right', 'No transpose', 'Backward', + $ 'Rowwise', M-K+I-1, N-K+I+IB-1, IB, + $ A( M-K+I, 1 ), LDA, WORK, LDWORK, A, LDA, + $ WORK( IB+1 ), LDWORK ) + END IF + 10 CONTINUE + MU = M - K + I + NB - 1 + NU = N - K + I + NB - 1 + ELSE + MU = M + NU = N + END IF +* +* Use unblocked code to factor the last or only block +* + IF( MU.GT.0 .AND. NU.GT.0 ) + $ CALL DGERQ2( MU, NU, A, LDA, TAU, WORK, IINFO ) +* + WORK( 1 ) = IWS + RETURN +* +* End of DGERQF +* + END diff --git a/2.3-1/src/fortran/lapack/dgesc2.f b/2.3-1/src/fortran/lapack/dgesc2.f new file mode 100644 index 00000000..1b0331f5 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgesc2.f @@ -0,0 +1,132 @@ + SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER LDA, N + DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ), RHS( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, TWO + PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TEMP +* .. +* .. External Subroutines .. + EXTERNAL DLASWP, DSCAL +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL IDAMAX, DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* +* Set constant to control owerflow +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* +* Apply permutations IPIV to RHS +* + CALL DLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 ) +* +* Solve for L part +* + DO 20 I = 1, N - 1 + DO 10 J = I + 1, N + RHS( J ) = RHS( J ) - A( J, I )*RHS( I ) + 10 CONTINUE + 20 CONTINUE +* +* Solve for U part +* + SCALE = ONE +* +* Check for scaling +* + I = IDAMAX( N, RHS, 1 ) + IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN + TEMP = ( ONE / TWO ) / ABS( RHS( I ) ) + CALL DSCAL( N, TEMP, RHS( 1 ), 1 ) + SCALE = SCALE*TEMP + END IF +* + DO 40 I = N, 1, -1 + TEMP = ONE / A( I, I ) + RHS( I ) = RHS( I )*TEMP + DO 30 J = I + 1, N + RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP ) + 30 CONTINUE + 40 CONTINUE +* +* Apply permutations JPIV to the solution (RHS) +* + CALL DLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 ) + RETURN +* +* End of DGESC2 +* + END diff --git a/2.3-1/src/fortran/lapack/dgesv.f b/2.3-1/src/fortran/lapack/dgesv.f new file mode 100644 index 00000000..220ef56f --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgesv.f @@ -0,0 +1,107 @@ + SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* 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 .. + EXTERNAL DGETRF, DGETRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGESV ', -INFO ) + RETURN + END IF +* +* Compute the LU factorization of A. +* + CALL DGETRF( N, N, A, LDA, IPIV, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, + $ INFO ) + END IF + RETURN +* +* End of DGESV +* + END diff --git a/2.3-1/src/fortran/lapack/dgesvd.f b/2.3-1/src/fortran/lapack/dgesvd.f new file mode 100644 index 00000000..0b62ca10 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgesvd.f @@ -0,0 +1,3401 @@ + SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBU, JOBVT + INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), + $ VT( LDVT, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, + $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS + INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IR, ISCL, + $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU, + $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU, + $ NRVT, WRKBL + DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM +* .. +* .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DBDSQR, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY, + $ DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + MINMN = MIN( M, N ) + WNTUA = LSAME( JOBU, 'A' ) + WNTUS = LSAME( JOBU, 'S' ) + WNTUAS = WNTUA .OR. WNTUS + WNTUO = LSAME( JOBU, 'O' ) + WNTUN = LSAME( JOBU, 'N' ) + WNTVA = LSAME( JOBVT, 'A' ) + WNTVS = LSAME( JOBVT, 'S' ) + WNTVAS = WNTVA .OR. WNTVS + WNTVO = LSAME( JOBVT, 'O' ) + WNTVN = LSAME( JOBVT, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* + IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN + INFO = -1 + ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR. + $ ( WNTVO .AND. WNTUO ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN + INFO = -9 + ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR. + $ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN + INFO = -11 + END IF +* +* 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.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + IF( M.GE.N .AND. MINMN.GT.0 ) THEN +* +* Compute space needed for DBDSQR +* + MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) + BDSPAC = 5*N + IF( M.GE.MNTHR ) THEN + IF( WNTUN ) THEN +* +* Path 1 (M much larger than N, JOBU='N') +* + MAXWRK = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, + $ -1 ) + MAXWRK = MAX( MAXWRK, 3*N+2*N* + $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) + IF( WNTVO .OR. WNTVAS ) + $ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* + $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC ) + MINWRK = MAX( 4*N, BDSPAC ) + ELSE IF( WNTUO .AND. WNTVN ) THEN +* +* Path 2 (M much larger than N, JOBU='O', JOBVT='N') +* + WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, + $ N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+2*N* + $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC ) + MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N ) + MINWRK = MAX( 3*N+M, BDSPAC ) + ELSE IF( WNTUO .AND. WNTVAS ) THEN +* +* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or +* 'A') +* + WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, + $ N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+2*N* + $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+( N-1 )* + $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC ) + MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N ) + MINWRK = MAX( 3*N+M, BDSPAC ) + ELSE IF( WNTUS .AND. WNTVN ) THEN +* +* Path 4 (M much larger than N, JOBU='S', JOBVT='N') +* + WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, + $ N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+2*N* + $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC ) + MAXWRK = N*N + WRKBL + MINWRK = MAX( 3*N+M, BDSPAC ) + ELSE IF( WNTUS .AND. WNTVO ) THEN +* +* Path 5 (M much larger than N, JOBU='S', JOBVT='O') +* + WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, + $ N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+2*N* + $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+( N-1 )* + $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC ) + MAXWRK = 2*N*N + WRKBL + MINWRK = MAX( 3*N+M, BDSPAC ) + ELSE IF( WNTUS .AND. WNTVAS ) THEN +* +* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or +* 'A') +* + WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, + $ N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+2*N* + $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+( N-1 )* + $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC ) + MAXWRK = N*N + WRKBL + MINWRK = MAX( 3*N+M, BDSPAC ) + ELSE IF( WNTUA .AND. WNTVN ) THEN +* +* Path 7 (M much larger than N, JOBU='A', JOBVT='N') +* + WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M, + $ M, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+2*N* + $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC ) + MAXWRK = N*N + WRKBL + MINWRK = MAX( 3*N+M, BDSPAC ) + ELSE IF( WNTUA .AND. WNTVO ) THEN +* +* Path 8 (M much larger than N, JOBU='A', JOBVT='O') +* + WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M, + $ M, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+2*N* + $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+( N-1 )* + $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC ) + MAXWRK = 2*N*N + WRKBL + MINWRK = MAX( 3*N+M, BDSPAC ) + ELSE IF( WNTUA .AND. WNTVAS ) THEN +* +* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or +* 'A') +* + WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M, + $ M, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+2*N* + $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+( N-1 )* + $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC ) + MAXWRK = N*N + WRKBL + MINWRK = MAX( 3*N+M, BDSPAC ) + END IF + ELSE +* +* Path 10 (M at least N, but not much larger) +* + MAXWRK = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, + $ -1, -1 ) + IF( WNTUS .OR. WNTUO ) + $ MAXWRK = MAX( MAXWRK, 3*N+N* + $ ILAENV( 1, 'DORGBR', 'Q', M, N, N, -1 ) ) + IF( WNTUA ) + $ MAXWRK = MAX( MAXWRK, 3*N+M* + $ ILAENV( 1, 'DORGBR', 'Q', M, M, N, -1 ) ) + IF( .NOT.WNTVN ) + $ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* + $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC ) + MINWRK = MAX( 3*N+M, BDSPAC ) + END IF + ELSE IF( MINMN.GT.0 ) THEN +* +* Compute space needed for DBDSQR +* + MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) + BDSPAC = 5*M + IF( N.GE.MNTHR ) THEN + IF( WNTVN ) THEN +* +* Path 1t(N much larger than M, JOBVT='N') +* + MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, + $ -1 ) + MAXWRK = MAX( MAXWRK, 3*M+2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + IF( WNTUO .OR. WNTUAS ) + $ MAXWRK = MAX( MAXWRK, 3*M+M* + $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC ) + MINWRK = MAX( 4*M, BDSPAC ) + ELSE IF( WNTVO .AND. WNTUN ) THEN +* +* Path 2t(N much larger than M, JOBU='N', JOBVT='O') +* + WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+( M-1 )* + $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC ) + MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M ) + MINWRK = MAX( 3*M+N, BDSPAC ) + ELSE IF( WNTVO .AND. WNTUAS ) THEN +* +* Path 3t(N much larger than M, JOBU='S' or 'A', +* JOBVT='O') +* + WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+( M-1 )* + $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC ) + MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M ) + MINWRK = MAX( 3*M+N, BDSPAC ) + ELSE IF( WNTVS .AND. WNTUN ) THEN +* +* Path 4t(N much larger than M, JOBU='N', JOBVT='S') +* + WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+( M-1 )* + $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC ) + MAXWRK = M*M + WRKBL + MINWRK = MAX( 3*M+N, BDSPAC ) + ELSE IF( WNTVS .AND. WNTUO ) THEN +* +* Path 5t(N much larger than M, JOBU='O', JOBVT='S') +* + WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+( M-1 )* + $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC ) + MAXWRK = 2*M*M + WRKBL + MINWRK = MAX( 3*M+N, BDSPAC ) + ELSE IF( WNTVS .AND. WNTUAS ) THEN +* +* Path 6t(N much larger than M, JOBU='S' or 'A', +* JOBVT='S') +* + WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+( M-1 )* + $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC ) + MAXWRK = M*M + WRKBL + MINWRK = MAX( 3*M+N, BDSPAC ) + ELSE IF( WNTVA .AND. WNTUN ) THEN +* +* Path 7t(N much larger than M, JOBU='N', JOBVT='A') +* + WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+( M-1 )* + $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC ) + MAXWRK = M*M + WRKBL + MINWRK = MAX( 3*M+N, BDSPAC ) + ELSE IF( WNTVA .AND. WNTUO ) THEN +* +* Path 8t(N much larger than M, JOBU='O', JOBVT='A') +* + WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+( M-1 )* + $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC ) + MAXWRK = 2*M*M + WRKBL + MINWRK = MAX( 3*M+N, BDSPAC ) + ELSE IF( WNTVA .AND. WNTUAS ) THEN +* +* Path 9t(N much larger than M, JOBU='S' or 'A', +* JOBVT='A') +* + WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+( M-1 )* + $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC ) + MAXWRK = M*M + WRKBL + MINWRK = MAX( 3*M+N, BDSPAC ) + END IF + ELSE +* +* Path 10t(N greater than M, but not much larger) +* + MAXWRK = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, + $ -1, -1 ) + IF( WNTVS .OR. WNTVO ) + $ MAXWRK = MAX( MAXWRK, 3*M+M* + $ ILAENV( 1, 'DORGBR', 'P', M, N, M, -1 ) ) + IF( WNTVA ) + $ MAXWRK = MAX( MAXWRK, 3*M+N* + $ ILAENV( 1, 'DORGBR', 'P', N, N, M, -1 ) ) + IF( .NOT.WNTUN ) + $ MAXWRK = MAX( MAXWRK, 3*M+( M-1 )* + $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC ) + MINWRK = MAX( 3*M+N, BDSPAC ) + END IF + END IF + MAXWRK = MAX( MAXWRK, MINWRK ) + WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGESVD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + RETURN + END IF +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = DLANGE( 'M', M, N, A, LDA, DUM ) + ISCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ISCL = 1 + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR ) + ELSE IF( ANRM.GT.BIGNUM ) THEN + ISCL = 1 + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR ) + END IF +* + IF( M.GE.N ) THEN +* +* 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.GE.MNTHR ) THEN +* + IF( WNTUN ) THEN +* +* 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) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Zero out below R +* + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), 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) +* + CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, + $ IERR ) + NCVT = 0 + IF( WNTVO .OR. WNTVAS ) THEN +* +* If right singular vectors desired, generate P'. +* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* + CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + NCVT = N + END IF + IWORK = IE + N +* +* Perform bidiagonal QR iteration, computing right +* singular vectors of A in A if desired +* (Workspace: need BDSPAC) +* + CALL DBDSQR( 'U', N, NCVT, 0, 0, S, WORK( IE ), A, LDA, + $ DUM, 1, DUM, 1, WORK( IWORK ), INFO ) +* +* If right singular vectors desired in VT, copy them there +* + IF( WNTVAS ) + $ CALL DLACPY( 'F', N, N, A, LDA, VT, LDVT ) +* + ELSE IF( WNTUO .AND. WNTVN ) THEN +* +* 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.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IR = 1 + IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN +* +* WORK(IU) is LDA by N, WORK(IR) is LDA by N +* + LDWRKU = LDA + LDWRKR = LDA + ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN +* +* 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 + END IF + ITAU = IR + LDWRKR*N + IWORK = ITAU + N +* +* Compute A=Q*R +* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to WORK(IR) and zero out below it +* + CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR ) + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ), + $ LDWRKR ) +* +* Generate Q in A +* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* + CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Generate left vectors bidiagonalizing R +* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* + CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + IWORK = IE + N +* +* Perform bidiagonal QR iteration, computing left +* singular vectors of R in WORK(IR) +* (Workspace: need N*N+BDSPAC) +* + CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, 1, + $ WORK( IR ), LDWRKR, DUM, 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) +* + DO 10 I = 1, M, LDWRKU + CHUNK = MIN( M-I+1, LDWRKU ) + CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), + $ LDA, WORK( IR ), LDWRKR, ZERO, + $ WORK( IU ), LDWRKU ) + CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, + $ A( I, 1 ), LDA ) + 10 CONTINUE +* + 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) +* + CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Generate left vectors bidiagonalizing A +* (Workspace: need 4*N, prefer 3*N+N*NB) +* + CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IWORK = IE + N +* +* Perform bidiagonal QR iteration, computing left +* singular vectors of A in A +* (Workspace: need BDSPAC) +* + CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, 1, + $ A, LDA, DUM, 1, WORK( IWORK ), INFO ) +* + END IF +* + ELSE IF( WNTUO .AND. WNTVAS ) THEN +* +* 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.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IR = 1 + IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN +* +* WORK(IU) is LDA by N and WORK(IR) is LDA by N +* + LDWRKU = LDA + LDWRKR = LDA + ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN +* +* 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 + END IF + ITAU = IR + LDWRKR*N + IWORK = ITAU + N +* +* Compute A=Q*R +* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to VT, zeroing out below it +* + CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) + IF( N.GT.1 ) + $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ VT( 2, 1 ), LDVT ) +* +* Generate Q in A +* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* + CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'L', N, N, VT, 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) +* + CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate right vectors bidiagonalizing R in VT +* (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB) +* + CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, LDVT, + $ WORK( IR ), LDWRKR, DUM, 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) +* + DO 20 I = 1, M, LDWRKU + CHUNK = MIN( M-I+1, LDWRKU ) + CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), + $ LDA, WORK( IR ), LDWRKR, ZERO, + $ WORK( IU ), LDWRKU ) + CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, + $ A( I, 1 ), LDA ) + 20 CONTINUE +* + ELSE +* +* Insufficient workspace for a fast algorithm +* + ITAU = 1 + IWORK = ITAU + N +* +* Compute A=Q*R +* (Workspace: need 2*N, prefer N+N*NB) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to VT, zeroing out below it +* + CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) + IF( N.GT.1 ) + $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ VT( 2, 1 ), LDVT ) +* +* Generate Q in A +* (Workspace: need 2*N, prefer N+N*NB) +* + CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply Q in A by left vectors bidiagonalizing R +* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* + CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, + $ WORK( ITAUQ ), A, LDA, WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate right vectors bidiagonalizing R in VT +* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* + CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, LDVT, + $ A, LDA, DUM, 1, WORK( IWORK ), INFO ) +* + END IF +* + ELSE IF( WNTUS ) THEN +* + IF( WNTVN ) THEN +* +* 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.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IR = 1 + IF( LWORK.GE.WRKBL+LDA*N ) THEN +* +* WORK(IR) is LDA by N +* + LDWRKR = LDA + ELSE +* +* WORK(IR) is N by N +* + LDWRKR = N + END IF + ITAU = IR + LDWRKR*N + IWORK = ITAU + N +* +* Compute A=Q*R +* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to WORK(IR), zeroing out below it +* + CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), + $ LDWRKR ) + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ WORK( IR+1 ), LDWRKR ) +* +* Generate Q in A +* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* + CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, + $ WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate left vectors bidiagonalizing R in WORK(IR) +* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* + CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + IWORK = IE + N +* +* Perform bidiagonal QR iteration, computing left +* singular vectors of R in WORK(IR) +* (Workspace: need N*N+BDSPAC) +* + CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, + $ 1, WORK( IR ), LDWRKR, DUM, 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) +* + CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, + $ WORK( IR ), LDWRKR, ZERO, U, 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) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (Workspace: need 2*N, prefer N+N*NB) +* + CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IE = ITAU + ITAUQ = IE + N + ITAUP = ITAUQ + N + IWORK = ITAUP + N +* +* Zero out below R in A +* + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), + $ LDA ) +* +* Bidiagonalize R in A +* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* + CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply Q in U by left vectors bidiagonalizing R +* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* + CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + IWORK = IE + N +* +* Perform bidiagonal QR iteration, computing left +* singular vectors of A in U +* (Workspace: need BDSPAC) +* + CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, + $ 1, U, LDU, DUM, 1, WORK( IWORK ), + $ INFO ) +* + END IF +* + ELSE IF( WNTVO ) THEN +* +* 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.GE.2*N*N+MAX( 4*N, BDSPAC ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IU = 1 + IF( LWORK.GE.WRKBL+2*LDA*N ) THEN +* +* WORK(IU) is LDA by N and WORK(IR) is LDA by N +* + LDWRKU = LDA + IR = IU + LDWRKU*N + LDWRKR = LDA + ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN +* +* 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 + END IF + 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) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to WORK(IU), zeroing out below it +* + CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), + $ LDWRKU ) + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ WORK( IU+1 ), LDWRKU ) +* +* Generate Q in A +* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) +* + CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, + $ WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + CALL 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) +* + CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), + $ WORK( IR ), LDWRKR, WORK( IU ), + $ LDWRKU, DUM, 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) +* + CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, + $ WORK( IU ), LDWRKU, ZERO, U, LDU ) +* +* Copy right singular vectors of R to A +* (Workspace: need N*N) +* + CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, + $ 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) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (Workspace: need 2*N, prefer N+N*NB) +* + CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IE = ITAU + ITAUQ = IE + N + ITAUP = ITAUQ + N + IWORK = ITAUP + N +* +* Zero out below R in A +* + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), + $ LDA ) +* +* Bidiagonalize R in A +* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* + CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply Q in U by left vectors bidiagonalizing R +* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* + CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate right vectors bidiagonalizing R in A +* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* + CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A, + $ LDA, U, LDU, DUM, 1, WORK( IWORK ), + $ INFO ) +* + END IF +* + ELSE IF( WNTVAS ) THEN +* +* 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.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IU = 1 + IF( LWORK.GE.WRKBL+LDA*N ) THEN +* +* WORK(IU) is LDA by N +* + LDWRKU = LDA + ELSE +* +* WORK(IU) is N by N +* + LDWRKU = N + END IF + ITAU = IU + LDWRKU*N + IWORK = ITAU + N +* +* Compute A=Q*R +* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to WORK(IU), zeroing out below it +* + CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), + $ LDWRKU ) + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ WORK( IU+1 ), LDWRKU ) +* +* Generate Q in A +* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* + CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, + $ WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, + $ LDVT ) +* +* Generate left bidiagonalizing vectors in WORK(IU) +* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* + CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate right bidiagonalizing vectors in VT +* (Workspace: need N*N+4*N-1, +* prefer N*N+3*N+(N-1)*NB) +* + CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, + $ LDVT, WORK( IU ), LDWRKU, DUM, 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) +* + CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, + $ WORK( IU ), LDWRKU, ZERO, U, 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) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (Workspace: need 2*N, prefer N+N*NB) +* + CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to VT, zeroing out below it +* + CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) + IF( N.GT.1 ) + $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ VT( 2, 1 ), 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) +* + CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply Q in U by left bidiagonalizing vectors +* in VT +* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* + CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, + $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate right bidiagonalizing vectors in VT +* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* + CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, + $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), + $ INFO ) +* + END IF +* + END IF +* + ELSE IF( WNTUA ) THEN +* + IF( WNTVN ) THEN +* +* 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 +* + IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IR = 1 + IF( LWORK.GE.WRKBL+LDA*N ) THEN +* +* WORK(IR) is LDA by N +* + LDWRKR = LDA + ELSE +* +* WORK(IR) is N by N +* + LDWRKR = N + END IF + 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) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Copy R to WORK(IR), zeroing out below it +* + CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), + $ LDWRKR ) + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ WORK( IR+1 ), LDWRKR ) +* +* Generate Q in U +* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) +* + CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, + $ WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate left bidiagonalizing vectors in WORK(IR) +* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* + CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + IWORK = IE + N +* +* Perform bidiagonal QR iteration, computing left +* singular vectors of R in WORK(IR) +* (Workspace: need N*N+BDSPAC) +* + CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, + $ 1, WORK( IR ), LDWRKR, DUM, 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) +* + CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, + $ WORK( IR ), LDWRKR, ZERO, A, LDA ) +* +* Copy left singular vectors of A from A to U +* + CALL DLACPY( 'F', M, N, A, LDA, U, 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) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (Workspace: need N+M, prefer N+M*NB) +* + CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IE = ITAU + ITAUQ = IE + N + ITAUP = ITAUQ + N + IWORK = ITAUP + N +* +* Zero out below R in A +* + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), + $ LDA ) +* +* Bidiagonalize R in A +* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* + CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply Q in U by left bidiagonalizing vectors +* in A +* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* + CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + IWORK = IE + N +* +* Perform bidiagonal QR iteration, computing left +* singular vectors of A in U +* (Workspace: need BDSPAC) +* + CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, + $ 1, U, LDU, DUM, 1, WORK( IWORK ), + $ INFO ) +* + END IF +* + ELSE IF( WNTVO ) THEN +* +* 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 +* + IF( LWORK.GE.2*N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IU = 1 + IF( LWORK.GE.WRKBL+2*LDA*N ) THEN +* +* WORK(IU) is LDA by N and WORK(IR) is LDA by N +* + LDWRKU = LDA + IR = IU + LDWRKU*N + LDWRKR = LDA + ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN +* +* 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 + END IF + 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) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB) +* + CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to WORK(IU), zeroing out below it +* + CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), + $ LDWRKU ) + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ 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) +* + CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, + $ WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + CALL 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) +* + CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), + $ WORK( IR ), LDWRKR, WORK( IU ), + $ LDWRKU, DUM, 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) +* + CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, + $ WORK( IU ), LDWRKU, ZERO, A, LDA ) +* +* Copy left singular vectors of A from A to U +* + CALL DLACPY( 'F', M, N, A, LDA, U, LDU ) +* +* Copy right singular vectors of R from WORK(IR) to A +* + CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, + $ 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) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (Workspace: need N+M, prefer N+M*NB) +* + CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IE = ITAU + ITAUQ = IE + N + ITAUP = ITAUQ + N + IWORK = ITAUP + N +* +* Zero out below R in A +* + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), + $ LDA ) +* +* Bidiagonalize R in A +* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* + CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply Q in U by left bidiagonalizing vectors +* in A +* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* + CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate right bidiagonalizing vectors in A +* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* + CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A, + $ LDA, U, LDU, DUM, 1, WORK( IWORK ), + $ INFO ) +* + END IF +* + ELSE IF( WNTVAS ) THEN +* +* 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 +* + IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IU = 1 + IF( LWORK.GE.WRKBL+LDA*N ) THEN +* +* WORK(IU) is LDA by N +* + LDWRKU = LDA + ELSE +* +* WORK(IU) is N by N +* + LDWRKU = N + END IF + 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) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) +* + CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to WORK(IU), zeroing out below it +* + CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), + $ LDWRKU ) + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ 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) +* + CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, + $ WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, + $ LDVT ) +* +* Generate left bidiagonalizing vectors in WORK(IU) +* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* + CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate right bidiagonalizing vectors in VT +* (Workspace: need N*N+4*N-1, +* prefer N*N+3*N+(N-1)*NB) +* + CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, + $ LDVT, WORK( IU ), LDWRKU, DUM, 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) +* + CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, + $ WORK( IU ), LDWRKU, ZERO, A, LDA ) +* +* Copy left singular vectors of A from A to U +* + CALL DLACPY( 'F', M, N, A, LDA, U, 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) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (Workspace: need N+M, prefer N+M*NB) +* + CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R from A to VT, zeroing out below it +* + CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) + IF( N.GT.1 ) + $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ VT( 2, 1 ), 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) +* + CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply Q in U by left bidiagonalizing vectors +* in VT +* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* + CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, + $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate right bidiagonalizing vectors in VT +* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* + CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, + $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), + $ INFO ) +* + END IF +* + END IF +* + END IF +* + 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) +* + CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, + $ IERR ) + IF( WNTUAS ) THEN +* +* 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) +* + CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) + IF( WNTUS ) + $ NCU = N + IF( WNTUA ) + $ NCU = M + CALL DORGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IF( WNTVAS ) THEN +* +* 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) +* + CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) + CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IF( WNTUO ) THEN +* +* If left singular vectors desired in A, generate left +* bidiagonalizing vectors in A +* (Workspace: need 4*N, prefer 3*N+N*NB) +* + CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IF( WNTVO ) THEN +* +* If right singular vectors desired in A, generate right +* bidiagonalizing vectors in A +* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* + CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IWORK = IE + N + IF( WNTUAS .OR. WNTUO ) + $ NRU = M + IF( WNTUN ) + $ NRU = 0 + IF( WNTVAS .OR. WNTVO ) + $ NCVT = N + IF( WNTVN ) + $ NCVT = 0 + IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN +* +* Perform bidiagonal QR iteration, if desired, computing +* left singular vectors in U and computing right singular +* vectors in VT +* (Workspace: need BDSPAC) +* + CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT, + $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO ) + ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN +* +* Perform bidiagonal QR iteration, if desired, computing +* left singular vectors in U and computing right singular +* vectors in A +* (Workspace: need BDSPAC) +* + CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), A, LDA, + $ U, LDU, DUM, 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) +* + CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT, + $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO ) + END IF +* + END IF +* + 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.GE.MNTHR ) THEN +* + IF( WNTVN ) THEN +* +* 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) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Zero out above L +* + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), 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) +* + CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, + $ IERR ) + IF( WNTUO .OR. WNTUAS ) THEN +* +* If left singular vectors desired, generate Q +* (Workspace: need 4*M, prefer 3*M+M*NB) +* + CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IWORK = IE + M + NRU = 0 + IF( WNTUO .OR. WNTUAS ) + $ NRU = M +* +* Perform bidiagonal QR iteration, computing left singular +* vectors of A in A if desired +* (Workspace: need BDSPAC) +* + CALL DBDSQR( 'U', M, 0, NRU, 0, S, WORK( IE ), DUM, 1, A, + $ LDA, DUM, 1, WORK( IWORK ), INFO ) +* +* If left singular vectors desired in U, copy them there +* + IF( WNTUAS ) + $ CALL DLACPY( 'F', M, M, A, LDA, U, LDU ) +* + ELSE IF( WNTVO .AND. WNTUN ) THEN +* +* 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.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IR = 1 + IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN +* +* WORK(IU) is LDA by N and WORK(IR) is LDA by M +* + LDWRKU = LDA + CHUNK = N + LDWRKR = LDA + ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN +* +* 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 + END IF + ITAU = IR + LDWRKR*M + IWORK = ITAU + M +* +* Compute A=L*Q +* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to WORK(IR) and zero out above it +* + CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, + $ WORK( IR+LDWRKR ), LDWRKR ) +* +* Generate Q in A +* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* + CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Generate right vectors bidiagonalizing L +* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) +* + CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + IWORK = IE + M +* +* Perform bidiagonal QR iteration, computing right +* singular vectors of L in WORK(IR) +* (Workspace: need M*M+BDSPAC) +* + CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), + $ WORK( IR ), LDWRKR, DUM, 1, DUM, 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) +* + DO 30 I = 1, N, CHUNK + BLK = MIN( N-I+1, CHUNK ) + CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ), + $ LDWRKR, A( 1, I ), LDA, ZERO, + $ WORK( IU ), LDWRKU ) + CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, + $ A( 1, I ), LDA ) + 30 CONTINUE +* + 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) +* + CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Generate right vectors bidiagonalizing A +* (Workspace: need 4*M, prefer 3*M+M*NB) +* + CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IWORK = IE + M +* +* Perform bidiagonal QR iteration, computing right +* singular vectors of A in A +* (Workspace: need BDSPAC) +* + CALL DBDSQR( 'L', M, N, 0, 0, S, WORK( IE ), A, LDA, + $ DUM, 1, DUM, 1, WORK( IWORK ), INFO ) +* + END IF +* + ELSE IF( WNTVO .AND. WNTUAS ) THEN +* +* 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.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IR = 1 + IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN +* +* WORK(IU) is LDA by N and WORK(IR) is LDA by M +* + LDWRKU = LDA + CHUNK = N + LDWRKR = LDA + ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN +* +* 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 + END IF + ITAU = IR + LDWRKR*M + IWORK = ITAU + M +* +* Compute A=L*Q +* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to U, zeroing about above it +* + CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), + $ LDU ) +* +* Generate Q in A +* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* + CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'U', M, M, U, 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) +* + CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate left vectors bidiagonalizing L in U +* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) +* + CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), + $ WORK( IR ), LDWRKR, U, LDU, DUM, 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)) +* + DO 40 I = 1, N, CHUNK + BLK = MIN( N-I+1, CHUNK ) + CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ), + $ LDWRKR, A( 1, I ), LDA, ZERO, + $ WORK( IU ), LDWRKU ) + CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, + $ A( 1, I ), LDA ) + 40 CONTINUE +* + ELSE +* +* Insufficient workspace for a fast algorithm +* + ITAU = 1 + IWORK = ITAU + M +* +* Compute A=L*Q +* (Workspace: need 2*M, prefer M+M*NB) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to U, zeroing out above it +* + CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), + $ LDU ) +* +* Generate Q in A +* (Workspace: need 2*M, prefer M+M*NB) +* + CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply right vectors bidiagonalizing L by Q in A +* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* + CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, + $ WORK( ITAUP ), A, LDA, WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate left vectors bidiagonalizing L in U +* (Workspace: need 4*M, prefer 3*M+M*NB) +* + CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), A, LDA, + $ U, LDU, DUM, 1, WORK( IWORK ), INFO ) +* + END IF +* + ELSE IF( WNTVS ) THEN +* + IF( WNTUN ) THEN +* +* 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.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IR = 1 + IF( LWORK.GE.WRKBL+LDA*M ) THEN +* +* WORK(IR) is LDA by M +* + LDWRKR = LDA + ELSE +* +* WORK(IR) is M by M +* + LDWRKR = M + END IF + ITAU = IR + LDWRKR*M + IWORK = ITAU + M +* +* Compute A=L*Q +* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to WORK(IR), zeroing out above it +* + CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), + $ LDWRKR ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, + $ WORK( IR+LDWRKR ), LDWRKR ) +* +* Generate Q in A +* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* + CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, + $ WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate right vectors bidiagonalizing L in +* WORK(IR) +* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) +* + CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + IWORK = IE + M +* +* Perform bidiagonal QR iteration, computing right +* singular vectors of L in WORK(IR) +* (Workspace: need M*M+BDSPAC) +* + CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), + $ WORK( IR ), LDWRKR, DUM, 1, DUM, 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) +* + CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ), + $ LDWRKR, A, LDA, ZERO, VT, 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) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy result to VT +* + CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (Workspace: need 2*M, prefer M+M*NB) +* + CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IE = ITAU + ITAUQ = IE + M + ITAUP = ITAUQ + M + IWORK = ITAUP + M +* +* Zero out above L in A +* + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), + $ LDA ) +* +* Bidiagonalize L in A +* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* + CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply right vectors bidiagonalizing L by Q in VT +* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* + CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, + $ WORK( ITAUP ), VT, LDVT, + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IWORK = IE + M +* +* Perform bidiagonal QR iteration, computing right +* singular vectors of A in VT +* (Workspace: need BDSPAC) +* + CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT, + $ LDVT, DUM, 1, DUM, 1, WORK( IWORK ), + $ INFO ) +* + END IF +* + ELSE IF( WNTUO ) THEN +* +* 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.GE.2*M*M+MAX( 4*M, BDSPAC ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IU = 1 + IF( LWORK.GE.WRKBL+2*LDA*M ) THEN +* +* WORK(IU) is LDA by M and WORK(IR) is LDA by M +* + LDWRKU = LDA + IR = IU + LDWRKU*M + LDWRKR = LDA + ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN +* +* 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 + END IF + 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) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to WORK(IU), zeroing out below it +* + CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), + $ LDWRKU ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, + $ WORK( IU+LDWRKU ), LDWRKU ) +* +* Generate Q in A +* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) +* + CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, + $ WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + CALL 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) +* + CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate left bidiagonalizing vectors in WORK(IR) +* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) +* + CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), + $ WORK( IU ), LDWRKU, WORK( IR ), + $ LDWRKR, DUM, 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) +* + CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), + $ LDWRKU, A, LDA, ZERO, VT, LDVT ) +* +* Copy left singular vectors of L to A +* (Workspace: need M*M) +* + CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, + $ 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) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (Workspace: need 2*M, prefer M+M*NB) +* + CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IE = ITAU + ITAUQ = IE + M + ITAUP = ITAUQ + M + IWORK = ITAUP + M +* +* Zero out above L in A +* + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), + $ LDA ) +* +* Bidiagonalize L in A +* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* + CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply right vectors bidiagonalizing L by Q in VT +* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* + CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, + $ WORK( ITAUP ), VT, LDVT, + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Generate left bidiagonalizing vectors of L in A +* (Workspace: need 4*M, prefer 3*M+M*NB) +* + CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, + $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), + $ INFO ) +* + END IF +* + ELSE IF( WNTUAS ) THEN +* +* 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.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IU = 1 + IF( LWORK.GE.WRKBL+LDA*M ) THEN +* +* WORK(IU) is LDA by N +* + LDWRKU = LDA + ELSE +* +* WORK(IU) is LDA by M +* + LDWRKU = M + END IF + ITAU = IU + LDWRKU*M + IWORK = ITAU + M +* +* Compute A=L*Q +* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to WORK(IU), zeroing out above it +* + CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), + $ LDWRKU ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, + $ WORK( IU+LDWRKU ), LDWRKU ) +* +* Generate Q in A +* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* + CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, + $ WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, + $ LDU ) +* +* Generate right bidiagonalizing vectors in WORK(IU) +* (Workspace: need M*M+4*M-1, +* prefer M*M+3*M+(M-1)*NB) +* + CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate left bidiagonalizing vectors in U +* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) +* + CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), + $ WORK( IU ), LDWRKU, U, LDU, DUM, 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) +* + CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), + $ LDWRKU, A, LDA, ZERO, VT, 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) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (Workspace: need 2*M, prefer M+M*NB) +* + CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to U, zeroing out above it +* + CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), + $ 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) +* + CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply right bidiagonalizing vectors in U by Q +* in VT +* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* + CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, + $ WORK( ITAUP ), VT, LDVT, + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Generate left bidiagonalizing vectors in U +* (Workspace: need 4*M, prefer 3*M+M*NB) +* + CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, + $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), + $ INFO ) +* + END IF +* + END IF +* + ELSE IF( WNTVA ) THEN +* + IF( WNTUN ) THEN +* +* 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 +* + IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IR = 1 + IF( LWORK.GE.WRKBL+LDA*M ) THEN +* +* WORK(IR) is LDA by M +* + LDWRKR = LDA + ELSE +* +* WORK(IR) is M by M +* + LDWRKR = M + END IF + 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) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Copy L to WORK(IR), zeroing out above it +* + CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), + $ LDWRKR ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, + $ WORK( IR+LDWRKR ), LDWRKR ) +* +* Generate Q in VT +* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) +* + CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, + $ WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate right bidiagonalizing vectors in WORK(IR) +* (Workspace: need M*M+4*M-1, +* prefer M*M+3*M+(M-1)*NB) +* + CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + IWORK = IE + M +* +* Perform bidiagonal QR iteration, computing right +* singular vectors of L in WORK(IR) +* (Workspace: need M*M+BDSPAC) +* + CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), + $ WORK( IR ), LDWRKR, DUM, 1, DUM, 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) +* + CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ), + $ LDWRKR, VT, LDVT, ZERO, A, LDA ) +* +* Copy right singular vectors of A from A to VT +* + CALL DLACPY( 'F', M, N, A, LDA, VT, 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) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (Workspace: need M+N, prefer M+N*NB) +* + CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IE = ITAU + ITAUQ = IE + M + ITAUP = ITAUQ + M + IWORK = ITAUP + M +* +* Zero out above L in A +* + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), + $ LDA ) +* +* Bidiagonalize L in A +* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* + CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply right bidiagonalizing vectors in A by Q +* in VT +* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* + CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, + $ WORK( ITAUP ), VT, LDVT, + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IWORK = IE + M +* +* Perform bidiagonal QR iteration, computing right +* singular vectors of A in VT +* (Workspace: need BDSPAC) +* + CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT, + $ LDVT, DUM, 1, DUM, 1, WORK( IWORK ), + $ INFO ) +* + END IF +* + ELSE IF( WNTUO ) THEN +* +* 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 +* + IF( LWORK.GE.2*M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IU = 1 + IF( LWORK.GE.WRKBL+2*LDA*M ) THEN +* +* WORK(IU) is LDA by M and WORK(IR) is LDA by M +* + LDWRKU = LDA + IR = IU + LDWRKU*M + LDWRKR = LDA + ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN +* +* 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 + END IF + 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) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB) +* + CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to WORK(IU), zeroing out above it +* + CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), + $ LDWRKU ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, + $ 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) +* + CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, + $ WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + CALL 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) +* + CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate left bidiagonalizing vectors in WORK(IR) +* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) +* + CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), + $ WORK( IU ), LDWRKU, WORK( IR ), + $ LDWRKR, DUM, 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) +* + CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), + $ LDWRKU, VT, LDVT, ZERO, A, LDA ) +* +* Copy right singular vectors of A from A to VT +* + CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT ) +* +* Copy left singular vectors of A from WORK(IR) to A +* + CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, + $ 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) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (Workspace: need M+N, prefer M+N*NB) +* + CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IE = ITAU + ITAUQ = IE + M + ITAUP = ITAUQ + M + IWORK = ITAUP + M +* +* Zero out above L in A +* + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), + $ LDA ) +* +* Bidiagonalize L in A +* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* + CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply right bidiagonalizing vectors in A by Q +* in VT +* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* + CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, + $ WORK( ITAUP ), VT, LDVT, + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Generate left bidiagonalizing vectors in A +* (Workspace: need 4*M, prefer 3*M+M*NB) +* + CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, + $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), + $ INFO ) +* + END IF +* + ELSE IF( WNTUAS ) THEN +* +* 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 +* + IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IU = 1 + IF( LWORK.GE.WRKBL+LDA*M ) THEN +* +* WORK(IU) is LDA by M +* + LDWRKU = LDA + ELSE +* +* WORK(IU) is M by M +* + LDWRKU = M + END IF + 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) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) +* + CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to WORK(IU), zeroing out above it +* + CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), + $ LDWRKU ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, + $ 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) +* + CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, + $ WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, + $ LDU ) +* +* Generate right bidiagonalizing vectors in WORK(IU) +* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) +* + CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate left bidiagonalizing vectors in U +* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) +* + CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), + $ WORK( IU ), LDWRKU, U, LDU, DUM, 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) +* + CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), + $ LDWRKU, VT, LDVT, ZERO, A, LDA ) +* +* Copy right singular vectors of A from A to VT +* + CALL DLACPY( 'F', M, N, A, LDA, VT, 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) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (Workspace: need M+N, prefer M+N*NB) +* + CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to U, zeroing out above it +* + CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), + $ 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) +* + CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply right bidiagonalizing vectors in U by Q +* in VT +* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* + CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, + $ WORK( ITAUP ), VT, LDVT, + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Generate left bidiagonalizing vectors in U +* (Workspace: need 4*M, prefer 3*M+M*NB) +* + CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, + $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), + $ INFO ) +* + END IF +* + END IF +* + END IF +* + 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) +* + CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, + $ IERR ) + IF( WNTUAS ) THEN +* +* 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) +* + CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) + CALL DORGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IF( WNTVAS ) THEN +* +* 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) +* + CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) + IF( WNTVA ) + $ NRVT = N + IF( WNTVS ) + $ NRVT = M + CALL DORGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IF( WNTUO ) THEN +* +* If left singular vectors desired in A, generate left +* bidiagonalizing vectors in A +* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) +* + CALL DORGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IF( WNTVO ) THEN +* +* If right singular vectors desired in A, generate right +* bidiagonalizing vectors in A +* (Workspace: need 4*M, prefer 3*M+M*NB) +* + CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IWORK = IE + M + IF( WNTUAS .OR. WNTUO ) + $ NRU = M + IF( WNTUN ) + $ NRU = 0 + IF( WNTVAS .OR. WNTVO ) + $ NCVT = N + IF( WNTVN ) + $ NCVT = 0 + IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN +* +* Perform bidiagonal QR iteration, if desired, computing +* left singular vectors in U and computing right singular +* vectors in VT +* (Workspace: need BDSPAC) +* + CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT, + $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO ) + ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN +* +* Perform bidiagonal QR iteration, if desired, computing +* left singular vectors in U and computing right singular +* vectors in A +* (Workspace: need BDSPAC) +* + CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), A, LDA, + $ U, LDU, DUM, 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) +* + CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT, + $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO ) + END IF +* + END IF +* + END IF +* +* If DBDSQR failed to converge, copy unconverged superdiagonals +* to WORK( 2:MINMN ) +* + IF( INFO.NE.0 ) THEN + IF( IE.GT.2 ) THEN + DO 50 I = 1, MINMN - 1 + WORK( I+1 ) = WORK( I+IE-1 ) + 50 CONTINUE + END IF + IF( IE.LT.2 ) THEN + DO 60 I = MINMN - 1, 1, -1 + WORK( I+1 ) = WORK( I+IE-1 ) + 60 CONTINUE + END IF + END IF +* +* Undo scaling if necessary +* + IF( ISCL.EQ.1 ) THEN + IF( ANRM.GT.BIGNUM ) + $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, + $ IERR ) + IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) + $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, WORK( 2 ), + $ MINMN, IERR ) + IF( ANRM.LT.SMLNUM ) + $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, + $ IERR ) + IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) + $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, WORK( 2 ), + $ MINMN, IERR ) + END IF +* +* Return optimal workspace in WORK(1) +* + WORK( 1 ) = MAXWRK +* + RETURN +* +* End of DGESVD +* + END diff --git a/2.3-1/src/fortran/lapack/dgesvx.f b/2.3-1/src/fortran/lapack/dgesvx.f new file mode 100644 index 00000000..0645a20c --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgesvx.f @@ -0,0 +1,479 @@ + SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, + $ WORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, TRANS + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ BERR( * ), C( * ), FERR( * ), R( * ), + $ WORK( * ), X( LDX, * ) +* .. +* +* 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 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU + CHARACTER NORM + INTEGER I, INFEQU, J + DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN, + $ ROWCND, RPVGRW, SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE, DLANTR + EXTERNAL LSAME, DLAMCH, DLANGE, DLANTR +* .. +* .. External Subroutines .. + EXTERNAL DGECON, DGEEQU, DGERFS, DGETRF, DGETRS, DLACPY, + $ DLAQGE, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + NOTRAN = LSAME( TRANS, 'N' ) + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + ROWEQU = .FALSE. + COLEQU = .FALSE. + ELSE + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + END IF +* +* Test the input parameters. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) ) + $ THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -10 + ELSE + IF( ROWEQU ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 10 J = 1, N + RCMIN = MIN( RCMIN, R( J ) ) + RCMAX = MAX( RCMAX, R( J ) ) + 10 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -11 + ELSE IF( N.GT.0 ) THEN + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + ROWCND = ONE + END IF + END IF + IF( COLEQU .AND. INFO.EQ.0 ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 20 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 20 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -12 + ELSE IF( N.GT.0 ) THEN + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + COLCND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGESVX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL DGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL DLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ EQUED ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF + END IF +* +* Scale the right hand side. +* + IF( NOTRAN ) THEN + IF( ROWEQU ) THEN + DO 40 J = 1, NRHS + DO 30 I = 1, N + B( I, J ) = R( I )*B( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE IF( COLEQU ) THEN + DO 60 J = 1, NRHS + DO 50 I = 1, N + B( I, J ) = C( I )*B( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF ) + CALL DGETRF( N, N, AF, LDAF, IPIV, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF, + $ WORK ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = DLANGE( 'M', N, INFO, A, LDA, WORK ) / RPVGRW + END IF + WORK( 1 ) = RPVGRW + RCOND = ZERO + RETURN + END IF + END IF +* +* Compute the norm of the matrix A and the +* reciprocal pivot growth factor RPVGRW. +* + IF( NOTRAN ) THEN + NORM = '1' + ELSE + NORM = 'I' + END IF + ANORM = DLANGE( NORM, N, N, A, LDA, WORK ) + RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AF, LDAF, WORK ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = DLANGE( 'M', N, N, A, LDA, WORK ) / RPVGRW + END IF +* +* Compute the reciprocal of the condition number of A. +* + CALL DGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO ) +* +* Compute the solution matrix X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, + $ LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* Transform the solution matrix X to a solution of the original +* system. +* + IF( NOTRAN ) THEN + IF( COLEQU ) THEN + DO 80 J = 1, NRHS + DO 70 I = 1, N + X( I, J ) = C( I )*X( I, J ) + 70 CONTINUE + 80 CONTINUE + DO 90 J = 1, NRHS + FERR( J ) = FERR( J ) / COLCND + 90 CONTINUE + END IF + ELSE IF( ROWEQU ) THEN + DO 110 J = 1, NRHS + DO 100 I = 1, N + X( I, J ) = R( I )*X( I, J ) + 100 CONTINUE + 110 CONTINUE + DO 120 J = 1, NRHS + FERR( J ) = FERR( J ) / ROWCND + 120 CONTINUE + END IF +* + WORK( 1 ) = RPVGRW +* +* Set INFO = N+1 if the matrix is singular to working precision. +* + IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) + $ INFO = N + 1 + RETURN +* +* End of DGESVX +* + END diff --git a/2.3-1/src/fortran/lapack/dgetc2.f b/2.3-1/src/fortran/lapack/dgetc2.f new file mode 100644 index 00000000..5842b213 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgetc2.f @@ -0,0 +1,146 @@ + SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IP, IPV, J, JP, JPV + DOUBLE PRECISION BIGNUM, EPS, SMIN, SMLNUM, XMAX +* .. +* .. External Subroutines .. + EXTERNAL DGER, DSWAP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Set constants to control overflow +* + INFO = 0 + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* +* Factorize A using complete pivoting. +* Set pivots less than SMIN to SMIN. +* + DO 40 I = 1, N - 1 +* +* Find max element in matrix A +* + XMAX = ZERO + DO 20 IP = I, N + DO 10 JP = I, N + IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN + XMAX = ABS( A( IP, JP ) ) + IPV = IP + JPV = JP + END IF + 10 CONTINUE + 20 CONTINUE + IF( I.EQ.1 ) + $ SMIN = MAX( EPS*XMAX, SMLNUM ) +* +* Swap rows +* + IF( IPV.NE.I ) + $ CALL DSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA ) + IPIV( I ) = IPV +* +* Swap columns +* + IF( JPV.NE.I ) + $ CALL DSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 ) + JPIV( I ) = JPV +* +* Check for singularity +* + IF( ABS( A( I, I ) ).LT.SMIN ) THEN + INFO = I + A( I, I ) = SMIN + END IF + DO 30 J = I + 1, N + A( J, I ) = A( J, I ) / A( I, I ) + 30 CONTINUE + CALL DGER( N-I, N-I, -ONE, A( I+1, I ), 1, A( I, I+1 ), LDA, + $ A( I+1, I+1 ), LDA ) + 40 CONTINUE +* + IF( ABS( A( N, N ) ).LT.SMIN ) THEN + INFO = N + A( N, N ) = SMIN + END IF +* + RETURN +* +* End of DGETC2 +* + END diff --git a/2.3-1/src/fortran/lapack/dgetf2.f b/2.3-1/src/fortran/lapack/dgetf2.f new file mode 100644 index 00000000..573b1408 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgetf2.f @@ -0,0 +1,147 @@ + SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION SFMIN + INTEGER I, J, JP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER IDAMAX + EXTERNAL DLAMCH, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL DGER, DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Compute machine safe minimum +* + SFMIN = DLAMCH('S') +* + DO 10 J = 1, MIN( M, N ) +* +* Find pivot and test for singularity. +* + JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) + IPIV( J ) = JP + IF( A( JP, J ).NE.ZERO ) THEN +* +* Apply the interchange to columns 1:N. +* + IF( JP.NE.J ) + $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) +* +* Compute elements J+1:M of J-th column. +* + IF( J.LT.M ) THEN + IF( ABS(A( J, J )) .GE. SFMIN ) THEN + CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) + ELSE + DO 20 I = 1, M-J + A( J+I, J ) = A( J+I, J ) / A( J, J ) + 20 CONTINUE + END IF + END IF +* + ELSE IF( INFO.EQ.0 ) THEN +* + INFO = J + END IF +* + IF( J.LT.MIN( M, N ) ) THEN +* +* Update trailing submatrix. +* + CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, + $ A( J+1, J+1 ), LDA ) + END IF + 10 CONTINUE + RETURN +* +* End of DGETF2 +* + END diff --git a/2.3-1/src/fortran/lapack/dgetrf.f b/2.3-1/src/fortran/lapack/dgetrf.f new file mode 100644 index 00000000..c5b9df33 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgetrf.f @@ -0,0 +1,159 @@ + SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IINFO, J, JB, NB +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN +* +* Use unblocked code. +* + CALL DGETF2( M, N, A, LDA, IPIV, INFO ) + ELSE +* +* Use blocked code. +* + DO 20 J = 1, MIN( M, N ), NB + JB = MIN( MIN( M, N )-J+1, NB ) +* +* Factor diagonal and subdiagonal blocks and test for exact +* singularity. +* + CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) +* +* Adjust INFO and the pivot indices. +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + J - 1 + DO 10 I = J, MIN( M, J+JB-1 ) + IPIV( I ) = J - 1 + IPIV( I ) + 10 CONTINUE +* +* Apply interchanges to columns 1:J-1. +* + CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) +* + IF( J+JB.LE.N ) THEN +* +* Apply interchanges to columns J+JB:N. +* + CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, + $ IPIV, 1 ) +* +* Compute block row of U. +* + CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, + $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), + $ LDA ) + IF( J+JB.LE.M ) THEN +* +* Update trailing submatrix. +* + CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, + $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, + $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), + $ LDA ) + END IF + END IF + 20 CONTINUE + END IF + RETURN +* +* End of DGETRF +* + END diff --git a/2.3-1/src/fortran/lapack/dgetri.f b/2.3-1/src/fortran/lapack/dgetri.f new file mode 100644 index 00000000..9f1c1182 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgetri.f @@ -0,0 +1,192 @@ + SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB, + $ NBMIN, NN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -3 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETRI', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, +* and the inverse is not computed. +* + CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO ) + IF( INFO.GT.0 ) + $ RETURN +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = MAX( LDWORK*NB, 1 ) + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) ) + END IF + ELSE + IWS = N + END IF +* +* Solve the equation inv(A)*L = inv(U) for inv(A). +* + IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN +* +* Use unblocked code. +* + DO 20 J = N, 1, -1 +* +* Copy current column of L to WORK and replace with zeros. +* + DO 10 I = J + 1, N + WORK( I ) = A( I, J ) + A( I, J ) = ZERO + 10 CONTINUE +* +* Compute current column of inv(A). +* + IF( J.LT.N ) + $ CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ), + $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 ) + 20 CONTINUE + ELSE +* +* Use blocked code. +* + NN = ( ( N-1 ) / NB )*NB + 1 + DO 50 J = NN, 1, -NB + JB = MIN( NB, N-J+1 ) +* +* Copy current block column of L to WORK and replace with +* zeros. +* + DO 40 JJ = J, J + JB - 1 + DO 30 I = JJ + 1, N + WORK( I+( JJ-J )*LDWORK ) = A( I, JJ ) + A( I, JJ ) = ZERO + 30 CONTINUE + 40 CONTINUE +* +* Compute current block column of inv(A). +* + IF( J+JB.LE.N ) + $ CALL DGEMM( 'No transpose', 'No transpose', N, JB, + $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA, + $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA ) + CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB, + $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA ) + 50 CONTINUE + END IF +* +* Apply column interchanges. +* + DO 60 J = N - 1, 1, -1 + JP = IPIV( J ) + IF( JP.NE.J ) + $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) + 60 CONTINUE +* + WORK( 1 ) = IWS + RETURN +* +* End of DGETRI +* + END diff --git a/2.3-1/src/fortran/lapack/dgetrs.f b/2.3-1/src/fortran/lapack/dgetrs.f new file mode 100644 index 00000000..b7d17b0a --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgetrs.f @@ -0,0 +1,149 @@ + SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLASWP, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( NOTRAN ) THEN +* +* Solve A * X = B. +* +* Apply row interchanges to the right hand sides. +* + CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) +* +* Solve L*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve U*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, A, LDA, B, LDB ) + ELSE +* +* Solve A' * X = B. +* +* Solve U'*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve L'*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, + $ A, LDA, B, LDB ) +* +* Apply row interchanges to the solution vectors. +* + CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) + END IF +* + RETURN +* +* End of DGETRS +* + END diff --git a/2.3-1/src/fortran/lapack/dggbak.f b/2.3-1/src/fortran/lapack/dggbak.f new file mode 100644 index 00000000..8ed9fbd4 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dggbak.f @@ -0,0 +1,220 @@ + SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, + $ LDV, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOB, SIDE + INTEGER IHI, ILO, INFO, LDV, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION LSCALE( * ), RSCALE( * ), V( LDV, * ) +* .. +* +* 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 .. + LOGICAL LEFTV, RIGHTV + INTEGER I, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + RIGHTV = LSAME( SIDE, 'R' ) + LEFTV = LSAME( SIDE, 'L' ) +* + INFO = 0 + IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. + $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN + INFO = -1 + ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ILO.LT.1 ) THEN + INFO = -4 + ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN + INFO = -4 + ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) ) + $ THEN + INFO = -5 + ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -8 + ELSE IF( LDV.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGBAK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + IF( M.EQ.0 ) + $ RETURN + IF( LSAME( JOB, 'N' ) ) + $ RETURN +* + IF( ILO.EQ.IHI ) + $ GO TO 30 +* +* Backward balance +* + IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN +* +* Backward transformation on right eigenvectors +* + IF( RIGHTV ) THEN + DO 10 I = ILO, IHI + CALL DSCAL( M, RSCALE( I ), V( I, 1 ), LDV ) + 10 CONTINUE + END IF +* +* Backward transformation on left eigenvectors +* + IF( LEFTV ) THEN + DO 20 I = ILO, IHI + CALL DSCAL( M, LSCALE( I ), V( I, 1 ), LDV ) + 20 CONTINUE + END IF + END IF +* +* Backward permutation +* + 30 CONTINUE + IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN +* +* Backward permutation on right eigenvectors +* + IF( RIGHTV ) THEN + IF( ILO.EQ.1 ) + $ GO TO 50 +* + DO 40 I = ILO - 1, 1, -1 + K = RSCALE( I ) + IF( K.EQ.I ) + $ GO TO 40 + CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 40 CONTINUE +* + 50 CONTINUE + IF( IHI.EQ.N ) + $ GO TO 70 + DO 60 I = IHI + 1, N + K = RSCALE( I ) + IF( K.EQ.I ) + $ GO TO 60 + CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 60 CONTINUE + END IF +* +* Backward permutation on left eigenvectors +* + 70 CONTINUE + IF( LEFTV ) THEN + IF( ILO.EQ.1 ) + $ GO TO 90 + DO 80 I = ILO - 1, 1, -1 + K = LSCALE( I ) + IF( K.EQ.I ) + $ GO TO 80 + CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 80 CONTINUE +* + 90 CONTINUE + IF( IHI.EQ.N ) + $ GO TO 110 + DO 100 I = IHI + 1, N + K = LSCALE( I ) + IF( K.EQ.I ) + $ GO TO 100 + CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 100 CONTINUE + END IF + END IF +* + 110 CONTINUE +* + RETURN +* +* End of DGGBAK +* + END diff --git a/2.3-1/src/fortran/lapack/dggbal.f b/2.3-1/src/fortran/lapack/dggbal.f new file mode 100644 index 00000000..2034880a --- /dev/null +++ b/2.3-1/src/fortran/lapack/dggbal.f @@ -0,0 +1,469 @@ + SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, + $ RSCALE, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOB + INTEGER IHI, ILO, INFO, LDA, LDB, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), LSCALE( * ), + $ RSCALE( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION THREE, SCLFAC + PARAMETER ( THREE = 3.0D+0, SCLFAC = 1.0D+1 ) +* .. +* .. Local Scalars .. + INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1, + $ K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN, + $ M, NR, NRP2 + DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, + $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, + $ SFMIN, SUM, T, TA, TB, TC +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG10, MAX, MIN, SIGN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. + $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGBAL', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + ILO = 1 + IHI = N + RETURN + END IF +* + IF( N.EQ.1 ) THEN + ILO = 1 + IHI = N + LSCALE( 1 ) = ONE + RSCALE( 1 ) = ONE + RETURN + END IF +* + IF( LSAME( JOB, 'N' ) ) THEN + ILO = 1 + IHI = N + DO 10 I = 1, N + LSCALE( I ) = ONE + RSCALE( I ) = ONE + 10 CONTINUE + RETURN + END IF +* + K = 1 + L = N + IF( LSAME( JOB, 'S' ) ) + $ GO TO 190 +* + GO TO 30 +* +* Permute the matrices A and B to isolate the eigenvalues. +* +* Find row with one nonzero in columns 1 through L +* + 20 CONTINUE + L = LM1 + IF( L.NE.1 ) + $ GO TO 30 +* + RSCALE( 1 ) = ONE + LSCALE( 1 ) = ONE + GO TO 190 +* + 30 CONTINUE + LM1 = L - 1 + DO 80 I = L, 1, -1 + DO 40 J = 1, LM1 + JP1 = J + 1 + IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) + $ GO TO 50 + 40 CONTINUE + J = L + GO TO 70 +* + 50 CONTINUE + DO 60 J = JP1, L + IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) + $ GO TO 80 + 60 CONTINUE + J = JP1 - 1 +* + 70 CONTINUE + M = L + IFLOW = 1 + GO TO 160 + 80 CONTINUE + GO TO 100 +* +* Find column with one nonzero in rows K through N +* + 90 CONTINUE + K = K + 1 +* + 100 CONTINUE + DO 150 J = K, L + DO 110 I = K, LM1 + IP1 = I + 1 + IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) + $ GO TO 120 + 110 CONTINUE + I = L + GO TO 140 + 120 CONTINUE + DO 130 I = IP1, L + IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) + $ GO TO 150 + 130 CONTINUE + I = IP1 - 1 + 140 CONTINUE + M = K + IFLOW = 2 + GO TO 160 + 150 CONTINUE + GO TO 190 +* +* Permute rows M and I +* + 160 CONTINUE + LSCALE( M ) = I + IF( I.EQ.M ) + $ GO TO 170 + CALL DSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA ) + CALL DSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB ) +* +* Permute columns M and J +* + 170 CONTINUE + RSCALE( M ) = J + IF( J.EQ.M ) + $ GO TO 180 + CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) + CALL DSWAP( L, B( 1, J ), 1, B( 1, M ), 1 ) +* + 180 CONTINUE + GO TO ( 20, 90 )IFLOW +* + 190 CONTINUE + ILO = K + IHI = L +* + IF( LSAME( JOB, 'P' ) ) THEN + DO 195 I = ILO, IHI + LSCALE( I ) = ONE + RSCALE( I ) = ONE + 195 CONTINUE + RETURN + END IF +* + IF( ILO.EQ.IHI ) + $ RETURN +* +* Balance the submatrix in rows ILO to IHI. +* + NR = IHI - ILO + 1 + DO 200 I = ILO, IHI + RSCALE( I ) = ZERO + LSCALE( I ) = ZERO +* + WORK( I ) = ZERO + WORK( I+N ) = ZERO + WORK( I+2*N ) = ZERO + WORK( I+3*N ) = ZERO + WORK( I+4*N ) = ZERO + WORK( I+5*N ) = ZERO + 200 CONTINUE +* +* Compute right side vector in resulting linear equations +* + BASL = LOG10( SCLFAC ) + DO 240 I = ILO, IHI + DO 230 J = ILO, IHI + TB = B( I, J ) + TA = A( I, J ) + IF( TA.EQ.ZERO ) + $ GO TO 210 + TA = LOG10( ABS( TA ) ) / BASL + 210 CONTINUE + IF( TB.EQ.ZERO ) + $ GO TO 220 + TB = LOG10( ABS( TB ) ) / BASL + 220 CONTINUE + WORK( I+4*N ) = WORK( I+4*N ) - TA - TB + WORK( J+5*N ) = WORK( J+5*N ) - TA - TB + 230 CONTINUE + 240 CONTINUE +* + COEF = ONE / DBLE( 2*NR ) + COEF2 = COEF*COEF + COEF5 = HALF*COEF2 + NRP2 = NR + 2 + BETA = ZERO + IT = 1 +* +* Start generalized conjugate gradient iteration +* + 250 CONTINUE +* + GAMMA = DDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) + + $ DDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 ) +* + EW = ZERO + EWC = ZERO + DO 260 I = ILO, IHI + EW = EW + WORK( I+4*N ) + EWC = EWC + WORK( I+5*N ) + 260 CONTINUE +* + GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2 + IF( GAMMA.EQ.ZERO ) + $ GO TO 350 + IF( IT.NE.1 ) + $ BETA = GAMMA / PGAMMA + T = COEF5*( EWC-THREE*EW ) + TC = COEF5*( EW-THREE*EWC ) +* + CALL DSCAL( NR, BETA, WORK( ILO ), 1 ) + CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 ) +* + CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 ) + CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 ) +* + DO 270 I = ILO, IHI + WORK( I ) = WORK( I ) + TC + WORK( I+N ) = WORK( I+N ) + T + 270 CONTINUE +* +* Apply matrix to vector +* + DO 300 I = ILO, IHI + KOUNT = 0 + SUM = ZERO + DO 290 J = ILO, IHI + IF( A( I, J ).EQ.ZERO ) + $ GO TO 280 + KOUNT = KOUNT + 1 + SUM = SUM + WORK( J ) + 280 CONTINUE + IF( B( I, J ).EQ.ZERO ) + $ GO TO 290 + KOUNT = KOUNT + 1 + SUM = SUM + WORK( J ) + 290 CONTINUE + WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM + 300 CONTINUE +* + DO 330 J = ILO, IHI + KOUNT = 0 + SUM = ZERO + DO 320 I = ILO, IHI + IF( A( I, J ).EQ.ZERO ) + $ GO TO 310 + KOUNT = KOUNT + 1 + SUM = SUM + WORK( I+N ) + 310 CONTINUE + IF( B( I, J ).EQ.ZERO ) + $ GO TO 320 + KOUNT = KOUNT + 1 + SUM = SUM + WORK( I+N ) + 320 CONTINUE + WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM + 330 CONTINUE +* + SUM = DDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) + + $ DDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 ) + ALPHA = GAMMA / SUM +* +* Determine correction to current iteration +* + CMAX = ZERO + DO 340 I = ILO, IHI + COR = ALPHA*WORK( I+N ) + IF( ABS( COR ).GT.CMAX ) + $ CMAX = ABS( COR ) + LSCALE( I ) = LSCALE( I ) + COR + COR = ALPHA*WORK( I ) + IF( ABS( COR ).GT.CMAX ) + $ CMAX = ABS( COR ) + RSCALE( I ) = RSCALE( I ) + COR + 340 CONTINUE + IF( CMAX.LT.HALF ) + $ GO TO 350 +* + CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 ) + CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 ) +* + PGAMMA = GAMMA + IT = IT + 1 + IF( IT.LE.NRP2 ) + $ GO TO 250 +* +* End generalized conjugate gradient iteration +* + 350 CONTINUE + SFMIN = DLAMCH( 'S' ) + SFMAX = ONE / SFMIN + LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE ) + LSFMAX = INT( LOG10( SFMAX ) / BASL ) + DO 360 I = ILO, IHI + IRAB = IDAMAX( N-ILO+1, A( I, ILO ), LDA ) + RAB = ABS( A( I, IRAB+ILO-1 ) ) + IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDB ) + RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) + LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) + IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) + IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) + LSCALE( I ) = SCLFAC**IR + ICAB = IDAMAX( IHI, A( 1, I ), 1 ) + CAB = ABS( A( ICAB, I ) ) + ICAB = IDAMAX( IHI, B( 1, I ), 1 ) + CAB = MAX( CAB, ABS( B( ICAB, I ) ) ) + LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE ) + JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) ) + JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) + RSCALE( I ) = SCLFAC**JC + 360 CONTINUE +* +* Row scaling of matrices A and B +* + DO 370 I = ILO, IHI + CALL DSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA ) + CALL DSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB ) + 370 CONTINUE +* +* Column scaling of matrices A and B +* + DO 380 J = ILO, IHI + CALL DSCAL( IHI, RSCALE( J ), A( 1, J ), 1 ) + CALL DSCAL( IHI, RSCALE( J ), B( 1, J ), 1 ) + 380 CONTINUE +* + RETURN +* +* End of DGGBAL +* + END diff --git a/2.3-1/src/fortran/lapack/dgges.f b/2.3-1/src/fortran/lapack/dgges.f new file mode 100644 index 00000000..ce29aa52 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgges.f @@ -0,0 +1,550 @@ + SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, DELCTG, N, A, LDA, B, LDB, + $ SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, + $ LDVSR, WORK, LWORK, BWORK, INFO ) +* +* -- LAPACK driver routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* June 30, 1999 +* +* .. Scalar Arguments .. + CHARACTER JOBVSL, JOBVSR, SORT + INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ) + DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), + $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), + $ VSR( LDVSR, * ), WORK( * ) +* .. +* .. Function Arguments .. + LOGICAL DELCTG + EXTERNAL DELCTG +* .. +* +* 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 DELZTG); +* +* DELZTG (input) LOGICAL FUNCTION of three DOUBLE PRECISION arguments +* DELZTG must be declared EXTERNAL in the calling subroutine. +* If SORT = 'N', DELZTG is not referenced. +* If SORT = 'S', DELZTG 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 +* DELZTG(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 DELZTG(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 DELZTG is true. (Complex conjugate pairs for which +* DELZTG 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 (LWORK) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= 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. +* +* 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 DELZTG=.TRUE. This could also +* be caused due to scaling. +* =N+3: reordering failed in DTGSEN. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, + $ LQUERY, LST2SL, WANTST + INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, + $ ILO, IP, IRIGHT, IROWS, ITAU, IWRK, MAXWRK, + $ MINWRK + DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL, + $ PVSR, SAFMAX, SAFMIN, SMLNUM +* .. +* .. Local Arrays .. + INTEGER IDUM( 1 ) + DOUBLE PRECISION DIF( 2 ) +* .. +* .. External Subroutines .. + EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD, + $ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGSEN, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode the input arguments +* + IF( LSAME( JOBVSL, 'N' ) ) THEN + IJOBVL = 1 + ILVSL = .FALSE. + ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN + IJOBVL = 2 + ILVSL = .TRUE. + ELSE + IJOBVL = -1 + ILVSL = .FALSE. + END IF +* + IF( LSAME( JOBVSR, 'N' ) ) THEN + IJOBVR = 1 + ILVSR = .FALSE. + ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN + IJOBVR = 2 + ILVSR = .TRUE. + ELSE + IJOBVR = -1 + ILVSR = .FALSE. + END IF +* + WANTST = LSAME( SORT, 'S' ) +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( IJOBVL.LE.0 ) THEN + INFO = -1 + ELSE IF( IJOBVR.LE.0 ) THEN + INFO = -2 + ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN + INFO = -15 + ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN + INFO = -17 + END IF +* +* 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.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + MINWRK = 7*( N+1 ) + 16 + MAXWRK = 7*( N+1 ) + N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) + + $ 16 + IF( ILVSL ) THEN + MAXWRK = MAX( MAXWRK, 7*( N+1 )+N* + $ ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) ) + END IF + WORK( 1 ) = MAXWRK + END IF +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -19 + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGES ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + SDIM = 0 + RETURN + END IF +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SAFMIN = DLAMCH( 'S' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + SMLNUM = SQRT( SAFMIN ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = DLANGE( 'M', N, N, A, LDA, WORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF + IF( ILASCL ) + $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) +* +* Scale B if max element outside range [SMLNUM,BIGNUM] +* + BNRM = DLANGE( 'M', N, N, B, LDB, WORK ) + ILBSCL = .FALSE. + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + BNRMTO = SMLNUM + ILBSCL = .TRUE. + ELSE IF( BNRM.GT.BIGNUM ) THEN + BNRMTO = BIGNUM + ILBSCL = .TRUE. + END IF + IF( ILBSCL ) + $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, 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 + CALL DGGBAL( 'P', N, A, LDA, B, 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 + CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) +* +* Apply the orthogonal transformation to matrix A +* (Workspace: need N, prefer N*NB) +* + CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, + $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), + $ LWORK+1-IWRK, IERR ) +* +* Initialize VSL +* (Workspace: need N, prefer N*NB) +* + IF( ILVSL ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL ) + CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, + $ VSL( ILO+1, ILO ), LDVSL ) + CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, + $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Initialize VSR +* + IF( ILVSR ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR ) +* +* Reduce to generalized Hessenberg form +* (Workspace: none needed) +* + CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, + $ LDVSL, VSR, LDVSR, IERR ) +* +* Perform QZ algorithm, computing Schur vectors if desired +* (Workspace: need N) +* + IWRK = ITAU + CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.GT.0 .AND. IERR.LE.N ) THEN + INFO = IERR + ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN + INFO = IERR - N + ELSE + INFO = N + 1 + END IF + GO TO 50 + END IF +* +* Sort eigenvalues ALPHA/BETA if desired +* (Workspace: need 4*N+16 ) +* + SDIM = 0 + IF( WANTST ) THEN +* +* Undo scaling on eigenvalues before DELZTGing +* + IF( ILASCL ) THEN + CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, + $ IERR ) + CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, + $ IERR ) + END IF + IF( ILBSCL ) + $ CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) +* +* Select eigenvalues +* + DO 10 I = 1, N + BWORK( I ) = DELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) + 10 CONTINUE +* + CALL DTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHAR, + $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL, + $ PVSR, DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, + $ IERR ) + IF( IERR.EQ.1 ) + $ INFO = N + 3 +* + END IF +* +* Apply back-permutation to VSL and VSR +* (Workspace: none needed) +* + IF( ILVSL ) + $ CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), N, VSL, LDVSL, IERR ) +* + IF( ILVSR ) + $ CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), N, VSR, 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 ) THEN + DO 20 I = 1, N + IF( ALPHAI( I ).NE.ZERO ) THEN + IF( ( ALPHAR( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) .OR. + $ ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) ) THEN + WORK( 1 ) = ABS( A( I, I ) / ALPHAR( I ) ) + BETA( I ) = BETA( I )*WORK( 1 ) + ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) + ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) + ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT. + $ ( ANRMTO / ANRM ) .OR. + $ ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) ) + $ THEN + WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) ) + BETA( I ) = BETA( I )*WORK( 1 ) + ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) + ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) + END IF + END IF + 20 CONTINUE + END IF +* + IF( ILBSCL ) THEN + DO 30 I = 1, N + IF( ALPHAI( I ).NE.ZERO ) THEN + IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR. + $ ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN + WORK( 1 ) = ABS( B( I, I ) / BETA( I ) ) + BETA( I ) = BETA( I )*WORK( 1 ) + ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) + ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) + END IF + END IF + 30 CONTINUE + END IF +* +* Undo scaling +* + IF( ILASCL ) THEN + CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR ) + CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR ) + CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR ) + END IF +* + IF( ILBSCL ) THEN + CALL DLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR ) + CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) + END IF +* + IF( WANTST ) THEN +* +* Check if reordering is correct +* + LASTSL = .TRUE. + LST2SL = .TRUE. + SDIM = 0 + IP = 0 + DO 40 I = 1, N + CURSL = DELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) + IF( ALPHAI( I ).EQ.ZERO ) THEN + IF( CURSL ) + $ SDIM = SDIM + 1 + IP = 0 + IF( CURSL .AND. .NOT.LASTSL ) + $ INFO = N + 2 + ELSE + IF( IP.EQ.1 ) THEN +* +* Last eigenvalue of conjugate pair +* + CURSL = CURSL .OR. LASTSL + LASTSL = CURSL + IF( CURSL ) + $ SDIM = SDIM + 2 + IP = -1 + IF( CURSL .AND. .NOT.LST2SL ) + $ INFO = N + 2 + ELSE +* +* First eigenvalue of conjugate pair +* + IP = 1 + END IF + END IF + LST2SL = LASTSL + LASTSL = CURSL + 40 CONTINUE +* + END IF +* + 50 CONTINUE +* + WORK( 1 ) = MAXWRK +* + RETURN +* +* End of DGGES +* + END diff --git a/2.3-1/src/fortran/lapack/dggev.f b/2.3-1/src/fortran/lapack/dggev.f new file mode 100644 index 00000000..4a204c33 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dggev.f @@ -0,0 +1,489 @@ + SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, + $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBVL, JOBVR + INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), + $ B( LDB, * ), BETA( * ), VL( LDVL, * ), + $ VR( LDVR, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY + CHARACTER CHTEMP + INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO, + $ IN, IRIGHT, IROWS, ITAU, IWRK, JC, JR, MAXWRK, + $ MINWRK + DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, + $ SMLNUM, TEMP +* .. +* .. Local Arrays .. + LOGICAL LDUMMA( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD, + $ DLACPY,DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode the input arguments +* + IF( LSAME( JOBVL, 'N' ) ) THEN + IJOBVL = 1 + ILVL = .FALSE. + ELSE IF( LSAME( JOBVL, 'V' ) ) THEN + IJOBVL = 2 + ILVL = .TRUE. + ELSE + IJOBVL = -1 + ILVL = .FALSE. + END IF +* + IF( LSAME( JOBVR, 'N' ) ) THEN + IJOBVR = 1 + ILVR = .FALSE. + ELSE IF( LSAME( JOBVR, 'V' ) ) THEN + IJOBVR = 2 + ILVR = .TRUE. + ELSE + IJOBVR = -1 + ILVR = .FALSE. + END IF + ILV = ILVL .OR. ILVR +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( IJOBVL.LE.0 ) THEN + INFO = -1 + ELSE IF( IJOBVR.LE.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN + INFO = -14 + END IF +* +* 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.EQ.0 ) THEN + MINWRK = MAX( 1, 8*N ) + MAXWRK = MAX( 1, N*( 7 + + $ ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) ) ) + MAXWRK = MAX( MAXWRK, N*( 7 + + $ ILAENV( 1, 'DORMQR', ' ', N, 1, N, 0 ) ) ) + IF( ILVL ) THEN + MAXWRK = MAX( MAXWRK, N*( 7 + + $ ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) ) ) + END IF + WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -16 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGEV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = DLANGE( 'M', N, N, A, LDA, WORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF + IF( ILASCL ) + $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) +* +* Scale B if max element outside range [SMLNUM,BIGNUM] +* + BNRM = DLANGE( 'M', N, N, B, LDB, WORK ) + ILBSCL = .FALSE. + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + BNRMTO = SMLNUM + ILBSCL = .TRUE. + ELSE IF( BNRM.GT.BIGNUM ) THEN + BNRMTO = BIGNUM + ILBSCL = .TRUE. + END IF + IF( ILBSCL ) + $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) +* +* Permute the matrices A, B to isolate eigenvalues if possible +* (Workspace: need 6*N) +* + ILEFT = 1 + IRIGHT = N + 1 + IWRK = IRIGHT + N + CALL DGGBAL( 'P', N, A, LDA, B, 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 ) THEN + ICOLS = N + 1 - ILO + ELSE + ICOLS = IROWS + END IF + ITAU = IWRK + IWRK = ITAU + IROWS + CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) +* +* Apply the orthogonal transformation to matrix A +* (Workspace: need N, prefer N*NB) +* + CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, + $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), + $ LWORK+1-IWRK, IERR ) +* +* Initialize VL +* (Workspace: need N, prefer N*NB) +* + IF( ILVL ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL ) + IF( IROWS.GT.1 ) THEN + CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, + $ VL( ILO+1, ILO ), LDVL ) + END IF + CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL, + $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Initialize VR +* + IF( ILVR ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR ) +* +* Reduce to generalized Hessenberg form +* (Workspace: none needed) +* + IF( ILV ) THEN +* +* Eigenvectors requested -- work on whole matrix. +* + CALL DGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL, + $ LDVL, VR, LDVR, IERR ) + ELSE + CALL DGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA, + $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR ) + END IF +* +* Perform QZ algorithm (Compute eigenvalues, and optionally, the +* Schur forms and Schur vectors) +* (Workspace: need N) +* + IWRK = ITAU + IF( ILV ) THEN + CHTEMP = 'S' + ELSE + CHTEMP = 'E' + END IF + CALL DHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.GT.0 .AND. IERR.LE.N ) THEN + INFO = IERR + ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN + INFO = IERR - N + ELSE + INFO = N + 1 + END IF + GO TO 110 + END IF +* +* Compute Eigenvectors +* (Workspace: need 6*N) +* + IF( ILV ) THEN + IF( ILVL ) THEN + IF( ILVR ) THEN + CHTEMP = 'B' + ELSE + CHTEMP = 'L' + END IF + ELSE + CHTEMP = 'R' + END IF + CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL, + $ VR, LDVR, N, IN, WORK( IWRK ), IERR ) + IF( IERR.NE.0 ) THEN + INFO = N + 2 + GO TO 110 + END IF +* +* Undo balancing on VL and VR and normalization +* (Workspace: none needed) +* + IF( ILVL ) THEN + CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), N, VL, LDVL, IERR ) + DO 50 JC = 1, N + IF( ALPHAI( JC ).LT.ZERO ) + $ GO TO 50 + TEMP = ZERO + IF( ALPHAI( JC ).EQ.ZERO ) THEN + DO 10 JR = 1, N + TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) ) + 10 CONTINUE + ELSE + DO 20 JR = 1, N + TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+ + $ ABS( VL( JR, JC+1 ) ) ) + 20 CONTINUE + END IF + IF( TEMP.LT.SMLNUM ) + $ GO TO 50 + TEMP = ONE / TEMP + IF( ALPHAI( JC ).EQ.ZERO ) THEN + DO 30 JR = 1, N + VL( JR, JC ) = VL( JR, JC )*TEMP + 30 CONTINUE + ELSE + DO 40 JR = 1, N + VL( JR, JC ) = VL( JR, JC )*TEMP + VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP + 40 CONTINUE + END IF + 50 CONTINUE + END IF + IF( ILVR ) THEN + CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), N, VR, LDVR, IERR ) + DO 100 JC = 1, N + IF( ALPHAI( JC ).LT.ZERO ) + $ GO TO 100 + TEMP = ZERO + IF( ALPHAI( JC ).EQ.ZERO ) THEN + DO 60 JR = 1, N + TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) ) + 60 CONTINUE + ELSE + DO 70 JR = 1, N + TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+ + $ ABS( VR( JR, JC+1 ) ) ) + 70 CONTINUE + END IF + IF( TEMP.LT.SMLNUM ) + $ GO TO 100 + TEMP = ONE / TEMP + IF( ALPHAI( JC ).EQ.ZERO ) THEN + DO 80 JR = 1, N + VR( JR, JC ) = VR( JR, JC )*TEMP + 80 CONTINUE + ELSE + DO 90 JR = 1, N + VR( JR, JC ) = VR( JR, JC )*TEMP + VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP + 90 CONTINUE + END IF + 100 CONTINUE + END IF +* +* End of eigenvector calculation +* + END IF +* +* Undo scaling if necessary +* + IF( ILASCL ) THEN + CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR ) + CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR ) + END IF +* + IF( ILBSCL ) THEN + CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) + END IF +* + 110 CONTINUE +* + WORK( 1 ) = MAXWRK +* + RETURN +* +* End of DGGEV +* + END diff --git a/2.3-1/src/fortran/lapack/dgghrd.f b/2.3-1/src/fortran/lapack/dgghrd.f new file mode 100644 index 00000000..6b8bbb08 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dgghrd.f @@ -0,0 +1,264 @@ + SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, + $ LDQ, Z, LDZ, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ + INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), + $ Z( LDZ, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ILQ, ILZ + INTEGER ICOMPQ, ICOMPZ, JCOL, JROW + DOUBLE PRECISION C, S, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARTG, DLASET, DROT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Decode COMPQ +* + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'V' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +* +* Decode COMPZ +* + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'V' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF +* +* Test the input parameters. +* + INFO = 0 + IF( ICOMPQ.LE.0 ) THEN + INFO = -1 + ELSE IF( ICOMPZ.LE.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ILO.LT.1 ) THEN + INFO = -4 + ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN + INFO = -11 + ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGHRD', -INFO ) + RETURN + END IF +* +* Initialize Q and Z if desired. +* + IF( ICOMPQ.EQ.3 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) + IF( ICOMPZ.EQ.3 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* +* Zero out lower triangle of B +* + DO 20 JCOL = 1, N - 1 + DO 10 JROW = JCOL + 1, N + B( JROW, JCOL ) = ZERO + 10 CONTINUE + 20 CONTINUE +* +* Reduce A and B +* + DO 40 JCOL = ILO, IHI - 2 +* + DO 30 JROW = IHI, JCOL + 2, -1 +* +* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) +* + TEMP = A( JROW-1, JCOL ) + CALL DLARTG( TEMP, A( JROW, JCOL ), C, S, + $ A( JROW-1, JCOL ) ) + A( JROW, JCOL ) = ZERO + CALL DROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA, + $ A( JROW, JCOL+1 ), LDA, C, S ) + CALL DROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB, + $ B( JROW, JROW-1 ), LDB, C, S ) + IF( ILQ ) + $ CALL DROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, S ) +* +* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) +* + TEMP = B( JROW, JROW ) + CALL DLARTG( TEMP, B( JROW, JROW-1 ), C, S, + $ B( JROW, JROW ) ) + B( JROW, JROW-1 ) = ZERO + CALL DROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S ) + CALL DROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C, + $ S ) + IF( ILZ ) + $ CALL DROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S ) + 30 CONTINUE + 40 CONTINUE +* + RETURN +* +* End of DGGHRD +* + END diff --git a/2.3-1/src/fortran/lapack/dhgeqz.f b/2.3-1/src/fortran/lapack/dhgeqz.f new file mode 100644 index 00000000..de137dc1 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dhgeqz.f @@ -0,0 +1,1243 @@ + SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, + $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, + $ LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ, JOB + INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), + $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), + $ WORK( * ), Z( LDZ, * ) +* .. +* +* 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 ) + DOUBLE PRECISION HALF, ZERO, ONE, SAFETY + PARAMETER ( HALF = 0.5D+0, ZERO = 0.0D+0, ONE = 1.0D+0, + $ SAFETY = 1.0D+2 ) +* .. +* .. Local Scalars .. + LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ, + $ LQUERY + INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST, + $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER, + $ JR, MAXIT + DOUBLE PRECISION A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11, + $ AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L, + $ AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I, + $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE, + $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, + $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, + $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1, + $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, + $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, + $ WR2 +* .. +* .. Local Arrays .. + DOUBLE PRECISION V( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANHS, DLAPY2, DLAPY3 + EXTERNAL LSAME, DLAMCH, DLANHS, DLAPY2, DLAPY3 +* .. +* .. External Subroutines .. + EXTERNAL DLAG2, DLARFG, DLARTG, DLASET, DLASV2, DROT, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Decode JOB, COMPQ, COMPZ +* + IF( LSAME( JOB, 'E' ) ) THEN + ILSCHR = .FALSE. + ISCHUR = 1 + ELSE IF( LSAME( JOB, 'S' ) ) THEN + ILSCHR = .TRUE. + ISCHUR = 2 + ELSE + ISCHUR = 0 + END IF +* + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'V' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +* + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'V' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF +* +* Check Argument Values +* + INFO = 0 + WORK( 1 ) = MAX( 1, N ) + LQUERY = ( LWORK.EQ.-1 ) + IF( ISCHUR.EQ.0 ) THEN + INFO = -1 + ELSE IF( ICOMPQ.EQ.0 ) THEN + INFO = -2 + ELSE IF( ICOMPZ.EQ.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( ILO.LT.1 ) THEN + INFO = -5 + ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN + INFO = -6 + ELSE IF( LDH.LT.N ) THEN + INFO = -8 + ELSE IF( LDT.LT.N ) THEN + INFO = -10 + ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN + INFO = -15 + ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN + INFO = -17 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -19 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DHGEQZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + WORK( 1 ) = DBLE( 1 ) + RETURN + END IF +* +* Initialize Q and Z +* + IF( ICOMPQ.EQ.3 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) + IF( ICOMPZ.EQ.3 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +* +* Machine Constants +* + IN = IHI + 1 - ILO + SAFMIN = DLAMCH( 'S' ) + SAFMAX = ONE / SAFMIN + ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) + ANORM = DLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK ) + BNORM = DLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK ) + ATOL = MAX( SAFMIN, ULP*ANORM ) + BTOL = MAX( SAFMIN, ULP*BNORM ) + ASCALE = ONE / MAX( SAFMIN, ANORM ) + BSCALE = ONE / MAX( SAFMIN, BNORM ) +* +* Set Eigenvalues IHI+1:N +* + DO 30 J = IHI + 1, N + IF( T( J, J ).LT.ZERO ) THEN + IF( ILSCHR ) THEN + DO 10 JR = 1, J + H( JR, J ) = -H( JR, J ) + T( JR, J ) = -T( JR, J ) + 10 CONTINUE + ELSE + H( J, J ) = -H( J, J ) + T( J, J ) = -T( J, J ) + END IF + IF( ILZ ) THEN + DO 20 JR = 1, N + Z( JR, J ) = -Z( JR, J ) + 20 CONTINUE + END IF + END IF + ALPHAR( J ) = H( J, J ) + ALPHAI( J ) = ZERO + BETA( J ) = T( J, J ) + 30 CONTINUE +* +* If IHI < ILO, skip QZ steps +* + IF( IHI.LT.ILO ) + $ GO TO 380 +* +* 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 ) THEN + IFRSTM = 1 + ILASTM = N + ELSE + IFRSTM = ILO + ILASTM = IHI + END IF + IITER = 0 + ESHIFT = ZERO + MAXIT = 30*( IHI-ILO+1 ) +* + DO 360 JITER = 1, MAXIT +* +* Split the matrix if possible. +* +* Two tests: +* 1: H(j,j-1)=0 or j=ILO +* 2: T(j,j)=0 +* + IF( ILAST.EQ.ILO ) THEN +* +* Special case: j=ILAST +* + GO TO 80 + ELSE + IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN + H( ILAST, ILAST-1 ) = ZERO + GO TO 80 + END IF + END IF +* + IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN + T( ILAST, ILAST ) = ZERO + GO TO 70 + END IF +* +* General case: j 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 ).GT.ABS( C21 )+ + $ ABS( C22R )+ABS( C22I ) ) THEN + T1 = DLAPY3( C12, C11R, C11I ) + CZ = C12 / T1 + SZR = -C11R / T1 + SZI = -C11I / T1 + ELSE + CZ = DLAPY2( C22R, C22I ) + IF( CZ.LE.SAFMIN ) THEN + CZ = ZERO + SZR = ONE + SZI = ZERO + ELSE + TEMPR = C22R / CZ + TEMPI = C22I / CZ + T1 = DLAPY2( CZ, C21 ) + CZ = CZ / T1 + SZR = -C21*TEMPR / T1 + SZI = C21*TEMPI / T1 + END IF + END IF +* +* 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.GT.WABS*BN ) THEN + 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.LE.SAFMIN ) THEN + CQ = ZERO + SQR = ONE + SQI = ZERO + ELSE + TEMPR = A1R / CQ + TEMPI = A1I / CQ + SQR = TEMPR*A2R + TEMPI*A2I + SQI = TEMPI*A2R - TEMPR*A2I + END IF + END IF + T1 = DLAPY3( CQ, SQR, SQI ) + CQ = CQ / T1 + SQR = SQR / T1 + SQI = 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.LT.ILO ) + $ GO TO 380 +* +* Reset counters +* + IITER = 0 + ESHIFT = ZERO + IF( .NOT.ILSCHR ) THEN + ILASTM = ILAST + IF( IFRSTM.GT.ILAST ) + $ IFRSTM = ILO + END IF + GO TO 350 + 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 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + AD22 = ( ASCALE*H( ILAST, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST ) + AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) / + $ ( BSCALE*T( IFIRST, IFIRST ) ) + AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) / + $ ( BSCALE*T( IFIRST, IFIRST ) ) + AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 ) +* + V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 + + $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L + V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )- + $ ( AD22-AD11L )+AD21*U12 )*AD21L + V( 3 ) = AD32L*AD21L +* + ISTART = IFIRST +* + CALL DLARFG( 3, V( 1 ), V( 2 ), 1, TAU ) + V( 1 ) = ONE +* +* Sweep +* + DO 290 J = ISTART, ILAST - 2 +* +* All but last elements: use 3x3 Householder transforms. +* +* Zero (j-1)st column of A +* + IF( J.GT.ISTART ) THEN + V( 1 ) = H( J, J-1 ) + V( 2 ) = H( J+1, J-1 ) + V( 3 ) = H( J+2, J-1 ) +* + CALL DLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU ) + V( 1 ) = ONE + H( J+1, J-1 ) = ZERO + H( J+2, J-1 ) = ZERO + END IF +* + DO 230 JC = J, ILASTM + TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* + $ H( J+2, JC ) ) + H( J, JC ) = H( J, JC ) - TEMP + H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) + H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) + TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* + $ T( J+2, JC ) ) + T( J, JC ) = T( J, JC ) - TEMP2 + T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) + T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) + 230 CONTINUE + IF( ILQ ) THEN + DO 240 JR = 1, N + TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )* + $ Q( JR, J+2 ) ) + Q( JR, J ) = Q( JR, J ) - TEMP + Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 ) + Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 ) + 240 CONTINUE + END IF +* +* Zero j-th column of B (see DLAGBC for details) +* +* Swap rows to pivot +* + ILPIVT = .FALSE. + TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) ) + TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) ) + IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN + SCALE = ZERO + U1 = ONE + U2 = ZERO + GO TO 250 + ELSE IF( TEMP.GE.TEMP2 ) THEN + W11 = T( J+1, J+1 ) + W21 = T( J+2, J+1 ) + W12 = T( J+1, J+2 ) + W22 = T( J+2, J+2 ) + U1 = T( J+1, J ) + U2 = T( J+2, J ) + ELSE + W21 = T( J+1, J+1 ) + W11 = T( J+2, J+1 ) + W22 = T( J+1, J+2 ) + W12 = T( J+2, J+2 ) + U2 = T( J+1, J ) + U1 = T( J+2, J ) + END IF +* +* Swap columns if nec. +* + IF( ABS( W12 ).GT.ABS( W11 ) ) THEN + ILPIVT = .TRUE. + TEMP = W12 + TEMP2 = W22 + W12 = W11 + W22 = W21 + W11 = TEMP + W21 = TEMP2 + END IF +* +* LU-factor +* + TEMP = W21 / W11 + U2 = U2 - TEMP*U1 + W22 = W22 - TEMP*W12 + W21 = ZERO +* +* Compute SCALE +* + SCALE = ONE + IF( ABS( W22 ).LT.SAFMIN ) THEN + SCALE = ZERO + U2 = ONE + U1 = -W12 / W11 + GO TO 250 + END IF + IF( ABS( W22 ).LT.ABS( U2 ) ) + $ SCALE = ABS( W22 / U2 ) + IF( ABS( W11 ).LT.ABS( U1 ) ) + $ SCALE = MIN( SCALE, ABS( W11 / U1 ) ) +* +* Solve +* + U2 = ( SCALE*U2 ) / W22 + U1 = ( SCALE*U1-W12*U2 ) / W11 +* + 250 CONTINUE + IF( ILPIVT ) THEN + TEMP = U2 + U2 = U1 + U1 = TEMP + END IF +* +* Compute Householder Vector +* + T1 = SQRT( SCALE**2+U1**2+U2**2 ) + TAU = ONE + SCALE / T1 + VS = -ONE / ( SCALE+T1 ) + V( 1 ) = ONE + V( 2 ) = VS*U1 + V( 3 ) = VS*U2 +* +* Apply transformations from the right. +* + DO 260 JR = IFRSTM, MIN( J+3, ILAST ) + TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* + $ H( JR, J+2 ) ) + H( JR, J ) = H( JR, J ) - TEMP + H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) + H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) + 260 CONTINUE + DO 270 JR = IFRSTM, J + 2 + TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* + $ T( JR, J+2 ) ) + T( JR, J ) = T( JR, J ) - TEMP + T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) + T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) + 270 CONTINUE + IF( ILZ ) THEN + DO 280 JR = 1, N + TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )* + $ Z( JR, J+2 ) ) + Z( JR, J ) = Z( JR, J ) - TEMP + Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 ) + Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) + 280 CONTINUE + END IF + T( J+1, J ) = ZERO + T( J+2, J ) = ZERO + 290 CONTINUE +* +* Last elements: Use Givens rotations +* +* Rotations from the left +* + J = ILAST - 1 + TEMP = H( J, J-1 ) + CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = ZERO +* + DO 300 JC = J, ILASTM + TEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = TEMP + TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = TEMP2 + 300 CONTINUE + IF( ILQ ) THEN + DO 310 JR = 1, N + TEMP = C*Q( JR, J ) + S*Q( JR, J+1 ) + Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 ) + Q( JR, J ) = TEMP + 310 CONTINUE + END IF +* +* Rotations from the right. +* + TEMP = T( J+1, J+1 ) + CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = ZERO +* + DO 320 JR = IFRSTM, ILAST + TEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = TEMP + 320 CONTINUE + DO 330 JR = IFRSTM, ILAST - 1 + TEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = TEMP + 330 CONTINUE + IF( ILZ ) THEN + DO 340 JR = 1, N + TEMP = C*Z( JR, J+1 ) + S*Z( JR, J ) + Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J ) + Z( JR, J+1 ) = TEMP + 340 CONTINUE + END IF +* +* End of Double-Shift code +* + END IF +* + GO TO 350 +* +* End of iteration loop +* + 350 CONTINUE + 360 CONTINUE +* +* Drop-through = non-convergence +* + INFO = ILAST + GO TO 420 +* +* Successful completion of all QZ steps +* + 380 CONTINUE +* +* Set Eigenvalues 1:ILO-1 +* + DO 410 J = 1, ILO - 1 + IF( T( J, J ).LT.ZERO ) THEN + IF( ILSCHR ) THEN + DO 390 JR = 1, J + H( JR, J ) = -H( JR, J ) + T( JR, J ) = -T( JR, J ) + 390 CONTINUE + ELSE + H( J, J ) = -H( J, J ) + T( J, J ) = -T( J, J ) + END IF + IF( ILZ ) THEN + DO 400 JR = 1, N + Z( JR, J ) = -Z( JR, J ) + 400 CONTINUE + END IF + END IF + ALPHAR( J ) = H( J, J ) + ALPHAI( J ) = ZERO + BETA( J ) = T( J, J ) + 410 CONTINUE +* +* Normal Termination +* + INFO = 0 +* +* Exit (other than argument error) -- return optimal workspace size +* + 420 CONTINUE + WORK( 1 ) = DBLE( N ) + RETURN +* +* End of DHGEQZ +* + END diff --git a/2.3-1/src/fortran/lapack/dhseqr.f b/2.3-1/src/fortran/lapack/dhseqr.f new file mode 100644 index 00000000..5b307fa8 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dhseqr.f @@ -0,0 +1,407 @@ + SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, + $ LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N + CHARACTER COMPZ, JOB +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), + $ Z( LDZ, * ) +* .. +* 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, 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 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=1: The DLAHQR vs DLAQR0 crossover point. +* Default: 75. (Must be at least 11.) +* +* ISPEC=2: Recommended deflation window size. +* This depends on ILO, IHI and NS. NS is the +* number of simultaneous shifts returned +* by ILAENV(ISPEC=4). (See ISPEC=4 below.) +* The default for (IHI-ILO+1).LE.500 is NS. +* The default for (IHI-ILO+1).GT.500 is 3*NS/2. +* +* ISPEC=3: Nibble crossover point. (See ILAENV for +* details.) Default: 14% of deflation window +* size. +* +* ISPEC=4: Number of simultaneous shifts, NS, in +* a multi-shift 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 NS is ignored. See ISPEC=1 above +* and comments in IPARM for details. +* +* The asterisks (**) indicate an ad-hoc +* function of N increasing from 10 to 64. +* +* ISPEC=5: Select structured matrix multiply. +* (See ILAENV for details.) Default: 3. +* +* ================================================================ +* 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=1,...) is recom- +* . mended. (The default value of NMIN is 75.) Using NL = 49 +* . allows up to six simultaneous shifts and a 16-by-16 +* . deflation window. ==== +* + INTEGER NTINY + PARAMETER ( NTINY = 11 ) + INTEGER NL + PARAMETER ( NL = 49 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Arrays .. + DOUBLE PRECISION HL( NL, NL ), WORKL( NL ) +* .. +* .. Local Scalars .. + INTEGER I, KBOT, NMIN + LOGICAL INITZ, LQUERY, WANTT, WANTZ +* .. +* .. External Functions .. + INTEGER ILAENV + LOGICAL LSAME + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DLAHQR, DLAQR0, DLASET, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* +* ==== Decode and check the input parameters. ==== +* + WANTT = LSAME( JOB, 'S' ) + INITZ = LSAME( COMPZ, 'I' ) + WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) + WORK( 1 ) = DBLE( MAX( 1, N ) ) + LQUERY = LWORK.EQ.-1 +* + INFO = 0 + IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -5 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN + INFO = -11 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF +* + IF( INFO.NE.0 ) THEN +* +* ==== Quick return in case of invalid argument. ==== +* + CALL XERBLA( 'DHSEQR', -INFO ) + RETURN +* + ELSE IF( N.EQ.0 ) THEN +* +* ==== Quick return in case N = 0; nothing to do. ==== +* + RETURN +* + ELSE IF( LQUERY ) THEN +* +* ==== Quick return in case of a workspace query ==== +* + CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, + $ IHI, Z, LDZ, WORK, LWORK, INFO ) +* ==== Ensure reported workspace size is backward-compatible with +* . previous LAPACK versions. ==== + WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) ) + RETURN +* + ELSE +* +* ==== copy eigenvalues isolated by DGEBAL ==== +* + DO 10 I = 1, ILO - 1 + WR( I ) = H( I, I ) + WI( I ) = ZERO + 10 CONTINUE + DO 20 I = IHI + 1, N + WR( I ) = H( I, I ) + WI( I ) = ZERO + 20 CONTINUE +* +* ==== Initialize Z, if requested ==== +* + IF( INITZ ) + $ CALL DLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) +* +* ==== Quick return if possible ==== +* + IF( ILO.EQ.IHI ) THEN + WR( ILO ) = H( ILO, ILO ) + WI( ILO ) = ZERO + RETURN + END IF +* +* ==== DLAHQR/DLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'DHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, + $ ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== DLAQR0 for big matrices; DLAHQR for small ones ==== +* + IF( N.GT.NMIN ) THEN + CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, + $ IHI, Z, LDZ, WORK, LWORK, INFO ) + ELSE +* +* ==== Small matrix ==== +* + CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, + $ IHI, Z, LDZ, INFO ) +* + IF( INFO.GT.0 ) THEN +* +* ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds +* . when DLAHQR fails. ==== +* + KBOT = INFO +* + IF( N.GE.NL ) THEN +* +* ==== Larger matrices have enough subdiagonal scratch +* . space to call DLAQR0 directly. ==== +* + CALL DLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, WR, + $ WI, ILO, IHI, Z, LDZ, WORK, 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. ==== +* + CALL DLACPY( 'A', N, N, H, LDH, HL, NL ) + HL( N+1, N ) = ZERO + CALL DLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), + $ NL ) + CALL DLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, WR, + $ WI, ILO, IHI, Z, LDZ, WORKL, NL, INFO ) + IF( WANTT .OR. INFO.NE.0 ) + $ CALL DLACPY( 'A', N, N, HL, NL, H, LDH ) + END IF + END IF + END IF +* +* ==== Clear out the trash, if necessary. ==== +* + IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) + $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) +* +* ==== Ensure reported workspace size is backward-compatible with +* . previous LAPACK versions. ==== +* + WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) ) + END IF +* +* ==== End of DHSEQR ==== +* + END diff --git a/2.3-1/src/fortran/lapack/disnan.f b/2.3-1/src/fortran/lapack/disnan.f new file mode 100644 index 00000000..52003561 --- /dev/null +++ b/2.3-1/src/fortran/lapack/disnan.f @@ -0,0 +1,33 @@ + LOGICAL FUNCTION DISNAN(DIN) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DIN +* .. +* +* 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 .. + LOGICAL DLAISNAN + EXTERNAL DLAISNAN +* .. +* .. Executable Statements .. + DISNAN = DLAISNAN(DIN,DIN) + RETURN + END diff --git a/2.3-1/src/fortran/lapack/dlabad.f b/2.3-1/src/fortran/lapack/dlabad.f new file mode 100644 index 00000000..05ff5d44 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlabad.f @@ -0,0 +1,55 @@ + SUBROUTINE DLABAD( SMALL, LARGE ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION LARGE, SMALL +* .. +* +* 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 .. + INTRINSIC LOG10, SQRT +* .. +* .. 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( LOG10( LARGE ).GT.2000.D0 ) THEN + SMALL = SQRT( SMALL ) + LARGE = SQRT( LARGE ) + END IF +* + RETURN +* +* End of DLABAD +* + END diff --git a/2.3-1/src/fortran/lapack/dlabrd.f b/2.3-1/src/fortran/lapack/dlabrd.f new file mode 100644 index 00000000..196b130c --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlabrd.f @@ -0,0 +1,290 @@ + SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, + $ LDY ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER LDA, LDX, LDY, M, N, NB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), + $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DLARFG, DSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* + IF( M.GE.N ) THEN +* +* Reduce to upper bidiagonal form +* + DO 10 I = 1, NB +* +* Update A(i:m,i) +* + CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ), + $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 ) + CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), + $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 ) +* +* Generate reflection Q(i) to annihilate A(i+1:m,i) +* + CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, + $ TAUQ( I ) ) + D( I ) = A( I, I ) + IF( I.LT.N ) THEN + A( I, I ) = ONE +* +* Compute Y(i+1:n,i) +* + CALL DGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ), + $ LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 ) + CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA, + $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), + $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) + CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX, + $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), + $ LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) + CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) +* +* Update A(i,i+1:n) +* + CALL DGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ), + $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA ) + CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), + $ LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA ) +* +* Generate reflection P(i) to annihilate A(i,i+2:n) +* + CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), + $ LDA, TAUP( I ) ) + E( I ) = A( I, I+1 ) + A( I, I+1 ) = ONE +* +* Compute X(i+1:m,i) +* + CALL DGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ), + $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY, + $ A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) + CALL DGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), + $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), + $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) + CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), + $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) + CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) + END IF + 10 CONTINUE + ELSE +* +* Reduce to lower bidiagonal form +* + DO 20 I = 1, NB +* +* Update A(i,i:n) +* + CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ), + $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA ) + CALL DGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA, + $ X( I, 1 ), LDX, ONE, A( I, I ), LDA ) +* +* Generate reflection P(i) to annihilate A(i,i+1:n) +* + CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, + $ TAUP( I ) ) + D( I ) = A( I, I ) + IF( I.LT.M ) THEN + A( I, I ) = ONE +* +* Compute X(i+1:m,i) +* + CALL DGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), + $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY, + $ A( I, I ), LDA, ZERO, X( 1, I ), 1 ) + CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), + $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), + $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 ) + CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), + $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) + CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) +* +* Update A(i+1:m,i) +* + CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), + $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 ) + CALL DGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), + $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 ) +* +* Generate reflection Q(i) to annihilate A(i+2:m,i) +* + CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, + $ TAUQ( I ) ) + E( I ) = A( I+1, I ) + A( I+1, I ) = ONE +* +* Compute Y(i+1:n,i) +* + CALL DGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ), + $ LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 ) + CALL DGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA, + $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), + $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) + CALL DGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX, + $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) + CALL DGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA, + $ Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) + CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) + END IF + 20 CONTINUE + END IF + RETURN +* +* End of DLABRD +* + END diff --git a/2.3-1/src/fortran/lapack/dlacn2.f b/2.3-1/src/fortran/lapack/dlacn2.f new file mode 100644 index 00000000..6705d256 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlacn2.f @@ -0,0 +1,214 @@ + SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER KASE, N + DOUBLE PRECISION EST +* .. +* .. Array Arguments .. + INTEGER ISGN( * ), ISAVE( 3 ) + DOUBLE PRECISION V( * ), X( * ) +* .. +* +* 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 .. + INTEGER ITMAX + PARAMETER ( ITMAX = 5 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, JLAST + DOUBLE PRECISION ALTSGN, ESTOLD, TEMP +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DASUM + EXTERNAL IDAMAX, DASUM +* .. +* .. External Subroutines .. + EXTERNAL DCOPY +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, NINT, SIGN +* .. +* .. Executable Statements .. +* + IF( KASE.EQ.0 ) THEN + DO 10 I = 1, N + X( I ) = ONE / DBLE( N ) + 10 CONTINUE + KASE = 1 + ISAVE( 1 ) = 1 + RETURN + END IF +* + GO TO ( 20, 40, 70, 110, 140 )ISAVE( 1 ) +* +* ................ ENTRY (ISAVE( 1 ) = 1) +* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. +* + 20 CONTINUE + IF( N.EQ.1 ) THEN + V( 1 ) = X( 1 ) + EST = ABS( V( 1 ) ) +* ... QUIT + GO TO 150 + END IF + EST = DASUM( N, X, 1 ) +* + DO 30 I = 1, N + X( I ) = SIGN( ONE, X( I ) ) + ISGN( I ) = NINT( X( I ) ) + 30 CONTINUE + KASE = 2 + ISAVE( 1 ) = 2 + RETURN +* +* ................ ENTRY (ISAVE( 1 ) = 2) +* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. +* + 40 CONTINUE + ISAVE( 2 ) = IDAMAX( N, X, 1 ) + ISAVE( 3 ) = 2 +* +* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. +* + 50 CONTINUE + DO 60 I = 1, N + X( I ) = ZERO + 60 CONTINUE + X( ISAVE( 2 ) ) = ONE + KASE = 1 + ISAVE( 1 ) = 3 + RETURN +* +* ................ ENTRY (ISAVE( 1 ) = 3) +* X HAS BEEN OVERWRITTEN BY A*X. +* + 70 CONTINUE + CALL DCOPY( N, X, 1, V, 1 ) + ESTOLD = EST + EST = DASUM( N, V, 1 ) + DO 80 I = 1, N + IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) ) + $ GO TO 90 + 80 CONTINUE +* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. + GO TO 120 +* + 90 CONTINUE +* TEST FOR CYCLING. + IF( EST.LE.ESTOLD ) + $ GO TO 120 +* + DO 100 I = 1, N + X( I ) = SIGN( ONE, X( I ) ) + ISGN( I ) = NINT( X( I ) ) + 100 CONTINUE + KASE = 2 + ISAVE( 1 ) = 4 + RETURN +* +* ................ ENTRY (ISAVE( 1 ) = 4) +* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. +* + 110 CONTINUE + JLAST = ISAVE( 2 ) + ISAVE( 2 ) = IDAMAX( N, X, 1 ) + IF( ( X( JLAST ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. + $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN + ISAVE( 3 ) = ISAVE( 3 ) + 1 + GO TO 50 + END IF +* +* ITERATION COMPLETE. FINAL STAGE. +* + 120 CONTINUE + ALTSGN = ONE + DO 130 I = 1, N + X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) + ALTSGN = -ALTSGN + 130 CONTINUE + KASE = 1 + ISAVE( 1 ) = 5 + RETURN +* +* ................ ENTRY (ISAVE( 1 ) = 5) +* X HAS BEEN OVERWRITTEN BY A*X. +* + 140 CONTINUE + TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) + IF( TEMP.GT.EST ) THEN + CALL DCOPY( N, X, 1, V, 1 ) + EST = TEMP + END IF +* + 150 CONTINUE + KASE = 0 + RETURN +* +* End of DLACN2 +* + END diff --git a/2.3-1/src/fortran/lapack/dlacon.f b/2.3-1/src/fortran/lapack/dlacon.f new file mode 100644 index 00000000..f113b03a --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlacon.f @@ -0,0 +1,205 @@ + SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER KASE, N + DOUBLE PRECISION EST +* .. +* .. Array Arguments .. + INTEGER ISGN( * ) + DOUBLE PRECISION V( * ), X( * ) +* .. +* +* 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 .. + INTEGER ITMAX + PARAMETER ( ITMAX = 5 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, ITER, J, JLAST, JUMP + DOUBLE PRECISION ALTSGN, ESTOLD, TEMP +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DASUM + EXTERNAL IDAMAX, DASUM +* .. +* .. External Subroutines .. + EXTERNAL DCOPY +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, NINT, SIGN +* .. +* .. Save statement .. + SAVE +* .. +* .. Executable Statements .. +* + IF( KASE.EQ.0 ) THEN + DO 10 I = 1, N + X( I ) = ONE / DBLE( N ) + 10 CONTINUE + KASE = 1 + JUMP = 1 + RETURN + END IF +* + GO TO ( 20, 40, 70, 110, 140 )JUMP +* +* ................ ENTRY (JUMP = 1) +* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. +* + 20 CONTINUE + IF( N.EQ.1 ) THEN + V( 1 ) = X( 1 ) + EST = ABS( V( 1 ) ) +* ... QUIT + GO TO 150 + END IF + EST = DASUM( N, X, 1 ) +* + DO 30 I = 1, N + X( I ) = SIGN( ONE, X( I ) ) + ISGN( I ) = NINT( X( I ) ) + 30 CONTINUE + KASE = 2 + JUMP = 2 + RETURN +* +* ................ ENTRY (JUMP = 2) +* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. +* + 40 CONTINUE + J = IDAMAX( N, X, 1 ) + ITER = 2 +* +* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. +* + 50 CONTINUE + DO 60 I = 1, N + X( I ) = ZERO + 60 CONTINUE + X( J ) = ONE + KASE = 1 + JUMP = 3 + RETURN +* +* ................ ENTRY (JUMP = 3) +* X HAS BEEN OVERWRITTEN BY A*X. +* + 70 CONTINUE + CALL DCOPY( N, X, 1, V, 1 ) + ESTOLD = EST + EST = DASUM( N, V, 1 ) + DO 80 I = 1, N + IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) ) + $ GO TO 90 + 80 CONTINUE +* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. + GO TO 120 +* + 90 CONTINUE +* TEST FOR CYCLING. + IF( EST.LE.ESTOLD ) + $ GO TO 120 +* + DO 100 I = 1, N + X( I ) = SIGN( ONE, X( I ) ) + ISGN( I ) = NINT( X( I ) ) + 100 CONTINUE + KASE = 2 + JUMP = 4 + RETURN +* +* ................ ENTRY (JUMP = 4) +* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. +* + 110 CONTINUE + JLAST = J + J = IDAMAX( N, X, 1 ) + IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN + ITER = ITER + 1 + GO TO 50 + END IF +* +* ITERATION COMPLETE. FINAL STAGE. +* + 120 CONTINUE + ALTSGN = ONE + DO 130 I = 1, N + X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) + ALTSGN = -ALTSGN + 130 CONTINUE + KASE = 1 + JUMP = 5 + RETURN +* +* ................ ENTRY (JUMP = 5) +* X HAS BEEN OVERWRITTEN BY A*X. +* + 140 CONTINUE + TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) + IF( TEMP.GT.EST ) THEN + CALL DCOPY( N, X, 1, V, 1 ) + EST = TEMP + END IF +* + 150 CONTINUE + KASE = 0 + RETURN +* +* End of DLACON +* + END diff --git a/2.3-1/src/fortran/lapack/dlacpy.f b/2.3-1/src/fortran/lapack/dlacpy.f new file mode 100644 index 00000000..d72603a5 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlacpy.f @@ -0,0 +1,87 @@ + SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* 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 .. + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, MIN( J, M ) + B( I, J ) = A( I, J ) + 10 CONTINUE + 20 CONTINUE + ELSE IF( LSAME( UPLO, 'L' ) ) THEN + DO 40 J = 1, N + DO 30 I = J, M + B( I, J ) = A( I, J ) + 30 CONTINUE + 40 CONTINUE + ELSE + DO 60 J = 1, N + DO 50 I = 1, M + B( I, J ) = A( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF + RETURN +* +* End of DLACPY +* + END diff --git a/2.3-1/src/fortran/lapack/dladiv.f b/2.3-1/src/fortran/lapack/dladiv.f new file mode 100644 index 00000000..b6a74d1b --- /dev/null +++ b/2.3-1/src/fortran/lapack/dladiv.f @@ -0,0 +1,62 @@ + SUBROUTINE DLADIV( A, B, C, D, P, Q ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, P, Q +* .. +* +* 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 .. + DOUBLE PRECISION E, F +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + IF( ABS( D ).LT.ABS( C ) ) THEN + 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 + END IF +* + RETURN +* +* End of DLADIV +* + END diff --git a/2.3-1/src/fortran/lapack/dlae2.f b/2.3-1/src/fortran/lapack/dlae2.f new file mode 100644 index 00000000..8e81c608 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlae2.f @@ -0,0 +1,123 @@ + SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, RT1, RT2 +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* +* Compute the eigenvalues +* + SM = A + C + DF = A - C + ADF = ABS( DF ) + TB = B + B + AB = ABS( TB ) + IF( ABS( A ).GT.ABS( C ) ) THEN + ACMX = A + ACMN = C + ELSE + ACMX = C + ACMN = A + END IF + IF( ADF.GT.AB ) THEN + RT = ADF*SQRT( ONE+( AB / ADF )**2 ) + ELSE IF( ADF.LT.AB ) THEN + RT = AB*SQRT( ONE+( ADF / AB )**2 ) + ELSE +* +* Includes case AB=ADF=0 +* + RT = AB*SQRT( TWO ) + END IF + IF( SM.LT.ZERO ) THEN + RT1 = HALF*( SM-RT ) +* +* 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.GT.ZERO ) THEN + RT1 = HALF*( SM+RT ) +* +* 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 = HALF*RT + RT2 = -HALF*RT + END IF + RETURN +* +* End of DLAE2 +* + END diff --git a/2.3-1/src/fortran/lapack/dlaev2.f b/2.3-1/src/fortran/lapack/dlaev2.f new file mode 100644 index 00000000..49402faa --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlaev2.f @@ -0,0 +1,169 @@ + SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) +* .. +* .. Local Scalars .. + INTEGER SGN1, SGN2 + DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, + $ TB, TN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* +* Compute the eigenvalues +* + SM = A + C + DF = A - C + ADF = ABS( DF ) + TB = B + B + AB = ABS( TB ) + IF( ABS( A ).GT.ABS( C ) ) THEN + ACMX = A + ACMN = C + ELSE + ACMX = C + ACMN = A + END IF + IF( ADF.GT.AB ) THEN + RT = ADF*SQRT( ONE+( AB / ADF )**2 ) + ELSE IF( ADF.LT.AB ) THEN + RT = AB*SQRT( ONE+( ADF / AB )**2 ) + ELSE +* +* Includes case AB=ADF=0 +* + RT = AB*SQRT( TWO ) + END IF + IF( SM.LT.ZERO ) THEN + RT1 = HALF*( SM-RT ) + 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.GT.ZERO ) THEN + RT1 = HALF*( SM+RT ) + 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 = HALF*RT + RT2 = -HALF*RT + SGN1 = 1 + END IF +* +* Compute the eigenvector +* + IF( DF.GE.ZERO ) THEN + CS = DF + RT + SGN2 = 1 + ELSE + CS = DF - RT + SGN2 = -1 + END IF + ACS = ABS( CS ) + IF( ACS.GT.AB ) THEN + CT = -TB / CS + SN1 = ONE / SQRT( ONE+CT*CT ) + CS1 = CT*SN1 + ELSE + IF( AB.EQ.ZERO ) THEN + CS1 = ONE + SN1 = ZERO + ELSE + TN = -CS / TB + CS1 = ONE / SQRT( ONE+TN*TN ) + SN1 = TN*CS1 + END IF + END IF + IF( SGN1.EQ.SGN2 ) THEN + TN = CS1 + CS1 = -SN1 + SN1 = TN + END IF + RETURN +* +* End of DLAEV2 +* + END diff --git a/2.3-1/src/fortran/lapack/dlaexc.f b/2.3-1/src/fortran/lapack/dlaexc.f new file mode 100644 index 00000000..18e7d247 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlaexc.f @@ -0,0 +1,354 @@ + SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, + $ INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL WANTQ + INTEGER INFO, J1, LDQ, LDT, N, N1, N2 +* .. +* .. Array Arguments .. + DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION TEN + PARAMETER ( TEN = 1.0D+1 ) + INTEGER LDD, LDX + PARAMETER ( LDD = 4, LDX = 2 ) +* .. +* .. Local Scalars .. + INTEGER IERR, J2, J3, J4, K, ND + DOUBLE PRECISION CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22, + $ T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2, + $ WR1, WR2, XNORM +* .. +* .. Local Arrays .. + DOUBLE PRECISION D( LDD, 4 ), U( 3 ), U1( 3 ), U2( 3 ), + $ X( LDX, 2 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DLANV2, DLARFG, DLARFX, DLARTG, DLASY2, + $ DROT +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Quick return if possible +* + IF( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 ) + $ RETURN + IF( J1+N1.GT.N ) + $ RETURN +* + J2 = J1 + 1 + J3 = J1 + 2 + J4 = J1 + 3 +* + IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN +* +* Swap two 1-by-1 blocks. +* + T11 = T( J1, J1 ) + T22 = T( J2, J2 ) +* +* Determine the transformation to perform the interchange. +* + CALL DLARTG( T( J1, J2 ), T22-T11, CS, SN, TEMP ) +* +* Apply transformation to the matrix T. +* + IF( J3.LE.N ) + $ CALL DROT( N-J1-1, T( J1, J3 ), LDT, T( J2, J3 ), LDT, CS, + $ SN ) + CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN ) +* + T( J1, J1 ) = T22 + T( J2, J2 ) = T11 +* + IF( WANTQ ) THEN +* +* Accumulate transformation in the matrix Q. +* + CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN ) + END IF +* + 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 + CALL DLACPY( 'Full', ND, ND, T( J1, J1 ), LDT, D, LDD ) + DNORM = DLANGE( 'Max', ND, ND, D, LDD, WORK ) +* +* Compute machine-dependent threshold for test for accepting +* swap. +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + THRESH = MAX( TEN*EPS*DNORM, SMLNUM ) +* +* Solve T11*X - X*T22 = scale*T12 for X. +* + CALL DLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD, + $ D( N1+1, N1+1 ), LDD, D( 1, N1+1 ), LDD, SCALE, X, + $ LDX, XNORM, IERR ) +* +* Swap the adjacent diagonal blocks. +* + K = N1 + N1 + N2 - 3 + GO TO ( 10, 20, 30 )K +* + 10 CONTINUE +* +* N1 = 1, N2 = 2: generate elementary reflector H so that: +* +* ( scale, X11, X12 ) H = ( 0, 0, * ) +* + U( 1 ) = SCALE + U( 2 ) = X( 1, 1 ) + U( 3 ) = X( 1, 2 ) + CALL DLARFG( 3, U( 3 ), U, 1, TAU ) + U( 3 ) = ONE + T11 = T( J1, J1 ) +* +* Perform swap provisionally on diagonal block in D. +* + CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK ) + CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK ) +* +* Test whether to reject swap. +* + IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 3, + $ 3 )-T11 ) ).GT.THRESH )GO TO 50 +* +* Accept swap: apply transformation to the entire matrix T. +* + CALL DLARFX( 'L', 3, N-J1+1, U, TAU, T( J1, J1 ), LDT, WORK ) + CALL DLARFX( 'R', J2, 3, U, TAU, T( 1, J1 ), LDT, WORK ) +* + T( J3, J1 ) = ZERO + T( J3, J2 ) = ZERO + T( J3, J3 ) = T11 +* + IF( WANTQ ) THEN +* +* Accumulate transformation in the matrix Q. +* + CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK ) + END IF + GO TO 40 +* + 20 CONTINUE +* +* N1 = 2, N2 = 1: generate elementary reflector H so that: +* +* H ( -X11 ) = ( * ) +* ( -X21 ) = ( 0 ) +* ( scale ) = ( 0 ) +* + U( 1 ) = -X( 1, 1 ) + U( 2 ) = -X( 2, 1 ) + U( 3 ) = SCALE + CALL DLARFG( 3, U( 1 ), U( 2 ), 1, TAU ) + U( 1 ) = ONE + T33 = T( J3, J3 ) +* +* Perform swap provisionally on diagonal block in D. +* + CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK ) + CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK ) +* +* Test whether to reject swap. +* + IF( MAX( ABS( D( 2, 1 ) ), ABS( D( 3, 1 ) ), ABS( D( 1, + $ 1 )-T33 ) ).GT.THRESH )GO TO 50 +* +* Accept swap: apply transformation to the entire matrix T. +* + CALL DLARFX( 'R', J3, 3, U, TAU, T( 1, J1 ), LDT, WORK ) + CALL DLARFX( 'L', 3, N-J1, U, TAU, T( J1, J2 ), LDT, WORK ) +* + T( J1, J1 ) = T33 + T( J2, J1 ) = ZERO + T( J3, J1 ) = ZERO +* + IF( WANTQ ) THEN +* +* Accumulate transformation in the matrix Q. +* + CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK ) + END IF + GO TO 40 +* + 30 CONTINUE +* +* 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( 1 ) = -X( 1, 1 ) + U1( 2 ) = -X( 2, 1 ) + U1( 3 ) = SCALE + CALL DLARFG( 3, U1( 1 ), U1( 2 ), 1, TAU1 ) + U1( 1 ) = ONE +* + TEMP = -TAU1*( X( 1, 2 )+U1( 2 )*X( 2, 2 ) ) + U2( 1 ) = -TEMP*U1( 2 ) - X( 2, 2 ) + U2( 2 ) = -TEMP*U1( 3 ) + U2( 3 ) = SCALE + CALL DLARFG( 3, U2( 1 ), U2( 2 ), 1, TAU2 ) + U2( 1 ) = ONE +* +* Perform swap provisionally on diagonal block in D. +* + CALL DLARFX( 'L', 3, 4, U1, TAU1, D, LDD, WORK ) + CALL DLARFX( 'R', 4, 3, U1, TAU1, D, LDD, WORK ) + CALL DLARFX( 'L', 3, 4, U2, TAU2, D( 2, 1 ), LDD, WORK ) + CALL DLARFX( 'R', 4, 3, U2, TAU2, D( 1, 2 ), LDD, WORK ) +* +* Test whether to reject swap. +* + IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 4, 1 ) ), + $ ABS( D( 4, 2 ) ) ).GT.THRESH )GO TO 50 +* +* Accept swap: apply transformation to the entire matrix T. +* + CALL DLARFX( 'L', 3, N-J1+1, U1, TAU1, T( J1, J1 ), LDT, WORK ) + CALL DLARFX( 'R', J4, 3, U1, TAU1, T( 1, J1 ), LDT, WORK ) + CALL DLARFX( 'L', 3, N-J1+1, U2, TAU2, T( J2, J1 ), LDT, WORK ) + CALL DLARFX( 'R', J4, 3, U2, TAU2, T( 1, J2 ), LDT, WORK ) +* + T( J3, J1 ) = ZERO + T( J3, J2 ) = ZERO + T( J4, J1 ) = ZERO + T( J4, J2 ) = ZERO +* + IF( WANTQ ) THEN +* +* Accumulate transformation in the matrix Q. +* + CALL DLARFX( 'R', N, 3, U1, TAU1, Q( 1, J1 ), LDQ, WORK ) + CALL DLARFX( 'R', N, 3, U2, TAU2, Q( 1, J2 ), LDQ, WORK ) + END IF +* + 40 CONTINUE +* + IF( N2.EQ.2 ) THEN +* +* Standardize new 2-by-2 block T11 +* + CALL DLANV2( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ), + $ T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN ) + CALL DROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT, + $ CS, SN ) + CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN ) + IF( WANTQ ) + $ CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN ) + END IF +* + IF( N1.EQ.2 ) THEN +* +* Standardize new 2-by-2 block T22 +* + J3 = J1 + N2 + J4 = J3 + 1 + CALL DLANV2( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ), + $ T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN ) + IF( J3+2.LE.N ) + $ CALL DROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ), + $ LDT, CS, SN ) + CALL DROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN ) + IF( WANTQ ) + $ CALL DROT( N, Q( 1, J3 ), 1, Q( 1, J4 ), 1, CS, SN ) + END IF +* + END IF + RETURN +* +* Exit with INFO = 1 if swap was rejected. +* + 50 CONTINUE + INFO = 1 + RETURN +* +* End of DLAEXC +* + END diff --git a/2.3-1/src/fortran/lapack/dlag2.f b/2.3-1/src/fortran/lapack/dlag2.f new file mode 100644 index 00000000..e754203b --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlag2.f @@ -0,0 +1,300 @@ + SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, + $ WR2, WI ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER LDA, LDB + DOUBLE PRECISION SAFMIN, SCALE1, SCALE2, WI, WR1, WR2 +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = ONE / TWO ) + DOUBLE PRECISION FUZZY1 + PARAMETER ( FUZZY1 = ONE+1.0D-5 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION A11, A12, A21, A22, ABI22, ANORM, AS11, AS12, + $ AS22, ASCALE, B11, B12, B22, BINV11, BINV22, + $ BMIN, BNORM, BSCALE, BSIZE, C1, C2, C3, C4, C5, + $ DIFF, DISCR, PP, QQ, R, RTMAX, RTMIN, S1, S2, + $ SAFMAX, SHIFT, SS, SUM, WABS, WBIG, WDET, + $ WSCALE, WSIZE, WSMALL +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SIGN, SQRT +* .. +* .. Executable Statements .. +* + RTMIN = SQRT( SAFMIN ) + RTMAX = ONE / RTMIN + SAFMAX = ONE / SAFMIN +* +* Scale A +* + ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ), + $ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN ) + ASCALE = ONE / ANORM + A11 = ASCALE*A( 1, 1 ) + A21 = ASCALE*A( 2, 1 ) + A12 = ASCALE*A( 1, 2 ) + A22 = ASCALE*A( 2, 2 ) +* +* Perturb B if necessary to insure non-singularity +* + B11 = B( 1, 1 ) + B12 = B( 1, 2 ) + B22 = B( 2, 2 ) + BMIN = RTMIN*MAX( ABS( B11 ), ABS( B12 ), ABS( B22 ), RTMIN ) + IF( ABS( B11 ).LT.BMIN ) + $ B11 = SIGN( BMIN, B11 ) + IF( ABS( B22 ).LT.BMIN ) + $ B22 = SIGN( BMIN, B22 ) +* +* Scale B +* + BNORM = MAX( ABS( B11 ), ABS( B12 )+ABS( B22 ), SAFMIN ) + BSIZE = MAX( ABS( B11 ), ABS( B22 ) ) + BSCALE = ONE / BSIZE + B11 = B11*BSCALE + B12 = B12*BSCALE + B22 = B22*BSCALE +* +* Compute larger eigenvalue by method described by C. van Loan +* +* ( AS is A shifted by -SHIFT*B ) +* + BINV11 = ONE / B11 + BINV22 = ONE / B22 + S1 = A11*BINV11 + S2 = A22*BINV22 + IF( ABS( S1 ).LE.ABS( S2 ) ) THEN + AS12 = A12 - S1*B12 + AS22 = A22 - S1*B22 + SS = A21*( BINV11*BINV22 ) + ABI22 = AS22*BINV22 - SS*B12 + PP = HALF*ABI22 + SHIFT = S1 + ELSE + AS12 = A12 - S2*B12 + AS11 = A11 - S2*B11 + SS = A21*( BINV11*BINV22 ) + ABI22 = -SS*B12 + PP = HALF*( AS11*BINV11+ABI22 ) + SHIFT = S2 + END IF + QQ = SS*AS12 + IF( ABS( PP*RTMIN ).GE.ONE ) THEN + DISCR = ( RTMIN*PP )**2 + QQ*SAFMIN + R = SQRT( ABS( DISCR ) )*RTMAX + ELSE + IF( PP**2+ABS( QQ ).LE.SAFMIN ) THEN + DISCR = ( RTMAX*PP )**2 + QQ*SAFMAX + R = SQRT( ABS( DISCR ) )*RTMIN + ELSE + DISCR = PP**2 + QQ + R = SQRT( ABS( DISCR ) ) + END IF + END IF +* +* 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.GE.ZERO .OR. R.EQ.ZERO ) THEN + SUM = PP + SIGN( R, PP ) + DIFF = PP - SIGN( R, PP ) + WBIG = SHIFT + SUM +* +* Compute smaller eigenvalue +* + WSMALL = SHIFT + DIFF + IF( HALF*ABS( WBIG ).GT.MAX( ABS( WSMALL ), SAFMIN ) ) THEN + WDET = ( A11*A22-A12*A21 )*( BINV11*BINV22 ) + WSMALL = WDET / WBIG + END IF +* +* Choose (real) eigenvalue closest to 2,2 element of A*B**(-1) +* for WR1. +* + IF( PP.GT.ABI22 ) THEN + WR1 = MIN( WBIG, WSMALL ) + WR2 = MAX( WBIG, WSMALL ) + ELSE + WR1 = MAX( WBIG, WSMALL ) + WR2 = MIN( WBIG, WSMALL ) + END IF + WI = ZERO + ELSE +* +* Complex eigenvalues +* + WR1 = SHIFT + PP + WR2 = WR1 + WI = R + END IF +* +* 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( ONE, ASCALE ) ) + C2 = SAFMIN*MAX( ONE, BNORM ) + C3 = BSIZE*SAFMIN + IF( ASCALE.LE.ONE .AND. BSIZE.LE.ONE ) THEN + C4 = MIN( ONE, ( ASCALE / SAFMIN )*BSIZE ) + ELSE + C4 = ONE + END IF + IF( ASCALE.LE.ONE .OR. BSIZE.LE.ONE ) THEN + C5 = MIN( ONE, ASCALE*BSIZE ) + ELSE + C5 = ONE + END IF +* +* Scale first eigenvalue +* + WABS = ABS( WR1 ) + ABS( WI ) + WSIZE = MAX( SAFMIN, C1, FUZZY1*( WABS*C2+C3 ), + $ MIN( C4, HALF*MAX( WABS, C5 ) ) ) + IF( WSIZE.NE.ONE ) THEN + WSCALE = ONE / WSIZE + IF( WSIZE.GT.ONE ) THEN + SCALE1 = ( MAX( ASCALE, BSIZE )*WSCALE )* + $ MIN( ASCALE, BSIZE ) + ELSE + SCALE1 = ( MIN( ASCALE, BSIZE )*WSCALE )* + $ MAX( ASCALE, BSIZE ) + END IF + WR1 = WR1*WSCALE + IF( WI.NE.ZERO ) THEN + WI = WI*WSCALE + WR2 = WR1 + SCALE2 = SCALE1 + END IF + ELSE + SCALE1 = ASCALE*BSIZE + SCALE2 = SCALE1 + END IF +* +* Scale second eigenvalue (if real) +* + IF( WI.EQ.ZERO ) THEN + WSIZE = MAX( SAFMIN, C1, FUZZY1*( ABS( WR2 )*C2+C3 ), + $ MIN( C4, HALF*MAX( ABS( WR2 ), C5 ) ) ) + IF( WSIZE.NE.ONE ) THEN + WSCALE = ONE / WSIZE + IF( WSIZE.GT.ONE ) THEN + SCALE2 = ( MAX( ASCALE, BSIZE )*WSCALE )* + $ MIN( ASCALE, BSIZE ) + ELSE + SCALE2 = ( MIN( ASCALE, BSIZE )*WSCALE )* + $ MAX( ASCALE, BSIZE ) + END IF + WR2 = WR2*WSCALE + ELSE + SCALE2 = ASCALE*BSIZE + END IF + END IF +* +* End of DLAG2 +* + RETURN + END diff --git a/2.3-1/src/fortran/lapack/dlagv2.f b/2.3-1/src/fortran/lapack/dlagv2.f new file mode 100644 index 00000000..15bcb0b9 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlagv2.f @@ -0,0 +1,287 @@ + SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, + $ CSR, SNR ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER LDA, LDB + DOUBLE PRECISION CSL, CSR, SNL, SNR +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ), + $ B( LDB, * ), BETA( 2 ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION ANORM, ASCALE, BNORM, BSCALE, H1, H2, H3, QQ, + $ R, RR, SAFMIN, SCALE1, SCALE2, T, ULP, WI, WR1, + $ WR2 +* .. +* .. External Subroutines .. + EXTERNAL DLAG2, DLARTG, DLASV2, DROT +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + SAFMIN = DLAMCH( 'S' ) + ULP = DLAMCH( 'P' ) +* +* Scale A +* + ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ), + $ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN ) + ASCALE = ONE / ANORM + A( 1, 1 ) = ASCALE*A( 1, 1 ) + A( 1, 2 ) = ASCALE*A( 1, 2 ) + A( 2, 1 ) = ASCALE*A( 2, 1 ) + A( 2, 2 ) = ASCALE*A( 2, 2 ) +* +* Scale B +* + BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ), + $ SAFMIN ) + BSCALE = ONE / BNORM + B( 1, 1 ) = BSCALE*B( 1, 1 ) + B( 1, 2 ) = BSCALE*B( 1, 2 ) + B( 2, 2 ) = BSCALE*B( 2, 2 ) +* +* Check if A can be deflated +* + IF( ABS( A( 2, 1 ) ).LE.ULP ) THEN + CSL = ONE + SNL = ZERO + CSR = ONE + SNR = ZERO + A( 2, 1 ) = ZERO + B( 2, 1 ) = ZERO +* +* Check if B is singular +* + ELSE IF( ABS( B( 1, 1 ) ).LE.ULP ) THEN + CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R ) + CSR = ONE + SNR = ZERO + CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL ) + CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL ) + A( 2, 1 ) = ZERO + B( 1, 1 ) = ZERO + B( 2, 1 ) = ZERO +* + ELSE IF( ABS( B( 2, 2 ) ).LE.ULP ) THEN + CALL DLARTG( A( 2, 2 ), A( 2, 1 ), CSR, SNR, T ) + SNR = -SNR + CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR ) + CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR ) + CSL = ONE + SNL = ZERO + A( 2, 1 ) = ZERO + B( 2, 1 ) = ZERO + B( 2, 2 ) = ZERO +* + ELSE +* +* B is nonsingular, first compute the eigenvalues of (A,B) +* + CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, + $ WI ) +* + IF( WI.EQ.ZERO ) THEN +* +* two real eigenvalues, compute s*A-w*B +* + H1 = SCALE1*A( 1, 1 ) - WR1*B( 1, 1 ) + H2 = SCALE1*A( 1, 2 ) - WR1*B( 1, 2 ) + H3 = SCALE1*A( 2, 2 ) - WR1*B( 2, 2 ) +* + RR = DLAPY2( H1, H2 ) + QQ = DLAPY2( SCALE1*A( 2, 1 ), H3 ) +* + IF( RR.GT.QQ ) THEN +* +* find right rotation matrix to zero 1,1 element of +* (sA - wB) +* + CALL DLARTG( H2, H1, CSR, SNR, T ) +* + ELSE +* +* find right rotation matrix to zero 2,1 element of +* (sA - wB) +* + CALL DLARTG( H3, SCALE1*A( 2, 1 ), CSR, SNR, T ) +* + END IF +* + SNR = -SNR + CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR ) + CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR ) +* +* compute inf norms of A and B +* + H1 = MAX( ABS( A( 1, 1 ) )+ABS( A( 1, 2 ) ), + $ ABS( A( 2, 1 ) )+ABS( A( 2, 2 ) ) ) + H2 = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ), + $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) ) +* + IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN +* +* find left rotation matrix Q to zero out B(2,1) +* + CALL DLARTG( B( 1, 1 ), B( 2, 1 ), CSL, SNL, R ) +* + ELSE +* +* find left rotation matrix Q to zero out A(2,1) +* + CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R ) +* + END IF +* + CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL ) + CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL ) +* + A( 2, 1 ) = ZERO + B( 2, 1 ) = ZERO +* + ELSE +* +* a pair of complex conjugate eigenvalues +* first compute the SVD of the matrix B +* + CALL DLASV2( B( 1, 1 ), B( 1, 2 ), B( 2, 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 +* + CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL ) + CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL ) + CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR ) + CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR ) +* + B( 2, 1 ) = ZERO + B( 1, 2 ) = ZERO +* + END IF +* + END IF +* +* Unscaling +* + A( 1, 1 ) = ANORM*A( 1, 1 ) + A( 2, 1 ) = ANORM*A( 2, 1 ) + A( 1, 2 ) = ANORM*A( 1, 2 ) + A( 2, 2 ) = ANORM*A( 2, 2 ) + B( 1, 1 ) = BNORM*B( 1, 1 ) + B( 2, 1 ) = BNORM*B( 2, 1 ) + B( 1, 2 ) = BNORM*B( 1, 2 ) + B( 2, 2 ) = BNORM*B( 2, 2 ) +* + IF( WI.EQ.ZERO ) THEN + ALPHAR( 1 ) = A( 1, 1 ) + ALPHAR( 2 ) = A( 2, 2 ) + ALPHAI( 1 ) = ZERO + ALPHAI( 2 ) = ZERO + BETA( 1 ) = B( 1, 1 ) + BETA( 2 ) = B( 2, 2 ) + ELSE + ALPHAR( 1 ) = ANORM*WR1 / SCALE1 / BNORM + ALPHAI( 1 ) = ANORM*WI / SCALE1 / BNORM + ALPHAR( 2 ) = ALPHAR( 1 ) + ALPHAI( 2 ) = -ALPHAI( 1 ) + BETA( 1 ) = ONE + BETA( 2 ) = ONE + END IF +* + RETURN +* +* End of DLAGV2 +* + END diff --git a/2.3-1/src/fortran/lapack/dlahqr.f b/2.3-1/src/fortran/lapack/dlahqr.f new file mode 100644 index 00000000..449a3770 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlahqr.f @@ -0,0 +1,501 @@ + SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) +* .. +* +* 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 .. + INTEGER ITMAX + PARAMETER ( ITMAX = 30 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0, TWO = 2.0d0 ) + DOUBLE PRECISION DAT1, DAT2 + PARAMETER ( DAT1 = 3.0d0 / 4.0d0, DAT2 = -0.4375d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S, + $ H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX, + $ SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST, + $ ULP, V2, V3 + INTEGER I, I1, I2, ITS, J, K, L, M, NH, NR, NZ +* .. +* .. Local Arrays .. + DOUBLE PRECISION V( 3 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DROT +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + IF( ILO.EQ.IHI ) THEN + WR( ILO ) = H( ILO, ILO ) + WI( ILO ) = ZERO + RETURN + END IF +* +* ==== clear out the trash ==== + DO 10 J = ILO, IHI - 3 + H( J+2, J ) = ZERO + H( J+3, J ) = ZERO + 10 CONTINUE + IF( ILO.LE.IHI-2 ) + $ H( IHI, IHI-2 ) = ZERO +* + NH = IHI - ILO + 1 + NZ = IHIZ - ILOZ + 1 +* +* Set machine-dependent constants for the stopping criterion. +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( 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 ) THEN + I1 = 1 + I2 = N + END IF +* +* 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 + 20 CONTINUE + L = ILO + IF( I.LT.ILO ) + $ GO TO 160 +* +* 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. +* + DO 140 ITS = 0, ITMAX +* +* Look for a single small subdiagonal element. +* + DO 30 K = I, L + 1, -1 + IF( ABS( H( K, K-1 ) ).LE.SMLNUM ) + $ GO TO 40 + TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) + IF( TST.EQ.ZERO ) THEN + IF( K-2.GE.ILO ) + $ TST = TST + ABS( H( K-1, K-2 ) ) + IF( K+1.LE.IHI ) + $ TST = TST + ABS( H( K+1, K ) ) + END IF +* ==== 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( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN + AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) ) + BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) ) + AA = MAX( ABS( H( K, K ) ), + $ ABS( H( K-1, K-1 )-H( K, K ) ) ) + BB = MIN( ABS( H( K, K ) ), + $ ABS( H( K-1, K-1 )-H( K, K ) ) ) + S = AA + AB + IF( BA*( AB / S ).LE.MAX( SMLNUM, + $ ULP*( BB*( AA / S ) ) ) )GO TO 40 + END IF + 30 CONTINUE + 40 CONTINUE + L = K + IF( L.GT.ILO ) THEN +* +* H(L,L-1) is negligible +* + H( L, L-1 ) = ZERO + END IF +* +* Exit from loop if a submatrix of order 1 or 2 has split off. +* + IF( L.GE.I-1 ) + $ GO TO 150 +* +* 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( .NOT.WANTT ) THEN + I1 = L + I2 = I + END IF +* + IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN +* +* Exceptional shift. +* + H11 = DAT1*S + H( I, I ) + H12 = DAT2*S + H21 = S + H22 = H11 + ELSE +* +* Prepare to use Francis' double shift +* (i.e. 2nd degree generalized Rayleigh quotient) +* + H11 = H( I-1, I-1 ) + H21 = H( I, I-1 ) + H12 = H( I-1, I ) + H22 = H( I, I ) + END IF + S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 ) + IF( S.EQ.ZERO ) THEN + RT1R = ZERO + RT1I = ZERO + RT2R = ZERO + RT2I = ZERO + ELSE + H11 = H11 / S + H21 = H21 / S + H12 = H12 / S + H22 = H22 / S + TR = ( H11+H22 ) / TWO + DET = ( H11-TR )*( H22-TR ) - H12*H21 + RTDISC = SQRT( ABS( DET ) ) + IF( DET.GE.ZERO ) THEN +* +* ==== 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( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN + RT1R = RT1R*S + RT2R = RT1R + ELSE + RT2R = RT2R*S + RT1R = RT2R + END IF + RT1I = ZERO + RT2I = ZERO + END IF + END IF +* +* Look for two consecutive small subdiagonal elements. +* + DO 50 M = I - 2, L, -1 +* 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 ) + S = ABS( H( M, M )-RT2R ) + ABS( RT2I ) + ABS( H21S ) + H21S = H( M+1, M ) / S + V( 1 ) = H21S*H( M, M+1 ) + ( H( M, M )-RT1R )* + $ ( ( H( M, M )-RT2R ) / S ) - RT1I*( RT2I / S ) + V( 2 ) = H21S*( H( M, M )+H( M+1, M+1 )-RT1R-RT2R ) + V( 3 ) = H21S*H( M+2, M+1 ) + S = ABS( V( 1 ) ) + ABS( V( 2 ) ) + ABS( V( 3 ) ) + V( 1 ) = V( 1 ) / S + V( 2 ) = V( 2 ) / S + V( 3 ) = V( 3 ) / S + IF( M.EQ.L ) + $ GO TO 60 + IF( ABS( H( M, M-1 ) )*( ABS( V( 2 ) )+ABS( V( 3 ) ) ).LE. + $ ULP*ABS( V( 1 ) )*( ABS( H( M-1, M-1 ) )+ABS( H( M, + $ M ) )+ABS( H( M+1, M+1 ) ) ) )GO TO 60 + 50 CONTINUE + 60 CONTINUE +* +* Double-shift QR step +* + DO 130 K = M, I - 1 +* +* 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. +* + NR = MIN( 3, I-K+1 ) + IF( K.GT.M ) + $ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 ) + CALL DLARFG( NR, V( 1 ), V( 2 ), 1, T1 ) + IF( K.GT.M ) THEN + H( K, K-1 ) = V( 1 ) + H( K+1, K-1 ) = ZERO + IF( K.LT.I-1 ) + $ H( K+2, K-1 ) = ZERO + ELSE IF( M.GT.L ) THEN + H( K, K-1 ) = -H( K, K-1 ) + END IF + V2 = V( 2 ) + T2 = T1*V2 + IF( NR.EQ.3 ) THEN + V3 = V( 3 ) + T3 = T1*V3 +* +* Apply G from the left to transform the rows of the matrix +* in columns K to I2. +* + DO 70 J = K, I2 + SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J ) + H( K, J ) = H( K, J ) - SUM*T1 + H( K+1, J ) = H( K+1, J ) - SUM*T2 + H( K+2, J ) = H( K+2, J ) - SUM*T3 + 70 CONTINUE +* +* Apply G from the right to transform the columns of the +* matrix in rows I1 to min(K+3,I). +* + DO 80 J = I1, MIN( K+3, I ) + SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 ) + H( J, K ) = H( J, K ) - SUM*T1 + H( J, K+1 ) = H( J, K+1 ) - SUM*T2 + H( J, K+2 ) = H( J, K+2 ) - SUM*T3 + 80 CONTINUE +* + IF( WANTZ ) THEN +* +* Accumulate transformations in the matrix Z +* + DO 90 J = ILOZ, IHIZ + SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 ) + Z( J, K ) = Z( J, K ) - SUM*T1 + Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 + Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3 + 90 CONTINUE + END IF + ELSE IF( NR.EQ.2 ) THEN +* +* Apply G from the left to transform the rows of the matrix +* in columns K to I2. +* + DO 100 J = K, I2 + SUM = H( K, J ) + V2*H( K+1, J ) + H( K, J ) = H( K, J ) - SUM*T1 + H( K+1, J ) = H( K+1, J ) - SUM*T2 + 100 CONTINUE +* +* Apply G from the right to transform the columns of the +* matrix in rows I1 to min(K+3,I). +* + DO 110 J = I1, I + SUM = H( J, K ) + V2*H( J, K+1 ) + H( J, K ) = H( J, K ) - SUM*T1 + H( J, K+1 ) = H( J, K+1 ) - SUM*T2 + 110 CONTINUE +* + IF( WANTZ ) THEN +* +* Accumulate transformations in the matrix Z +* + DO 120 J = ILOZ, IHIZ + SUM = Z( J, K ) + V2*Z( J, K+1 ) + Z( J, K ) = Z( J, K ) - SUM*T1 + Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 + 120 CONTINUE + END IF + END IF + 130 CONTINUE +* + 140 CONTINUE +* +* Failure to converge in remaining number of iterations +* + INFO = I + RETURN +* + 150 CONTINUE +* + IF( L.EQ.I ) THEN +* +* H(I,I-1) is negligible: one eigenvalue has converged. +* + WR( I ) = H( I, I ) + WI( I ) = ZERO + ELSE IF( L.EQ.I-1 ) THEN +* +* 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. +* + CALL DLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ), + $ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ), + $ CS, SN ) +* + IF( WANTT ) THEN +* +* Apply the transformation to the rest of H. +* + IF( I2.GT.I ) + $ CALL DROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH, + $ CS, SN ) + CALL DROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN ) + END IF + IF( WANTZ ) THEN +* +* Apply the transformation to Z. +* + CALL DROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN ) + END IF + END IF +* +* return to start of the main loop with new value of I. +* + I = L - 1 + GO TO 20 +* + 160 CONTINUE + RETURN +* +* End of DLAHQR +* + END diff --git a/2.3-1/src/fortran/lapack/dlahr2.f b/2.3-1/src/fortran/lapack/dlahr2.f new file mode 100644 index 00000000..6af74977 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlahr2.f @@ -0,0 +1,238 @@ + SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER K, LDA, LDT, LDY, N, NB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), + $ Y( LDY, NB ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, + $ ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION EI +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, + $ DLARFG, DSCAL, DTRMM, DTRMV +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* + DO 10 I = 1, NB + IF( I.GT.1 ) THEN +* +* Update A(K+1:N,I) +* +* Update I-th column of A - Y * V' +* + CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, + $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 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 +* + CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) + CALL DTRMV( 'Lower', 'Transpose', 'UNIT', + $ I-1, A( K+1, 1 ), + $ LDA, T( 1, NB ), 1 ) +* +* w := w + V2'*b2 +* + CALL DGEMV( 'Transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), + $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) +* +* w := T'*w +* + CALL DTRMV( 'Upper', 'Transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, NB ), 1 ) +* +* b2 := b2 - V2*w +* + CALL DGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, + $ A( K+I, 1 ), + $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) +* +* b1 := b1 - V1*w +* + CALL DTRMV( 'Lower', 'NO TRANSPOSE', + $ 'UNIT', I-1, + $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) + CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) +* + A( K+I-1, I-1 ) = EI + END IF +* +* Generate the elementary reflector H(I) to annihilate +* A(K+I+1:N,I) +* + CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, + $ TAU( I ) ) + EI = A( K+I, I ) + A( K+I, I ) = ONE +* +* Compute Y(K+1:N,I) +* + CALL DGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, + $ ONE, A( K+1, I+1 ), + $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) + CALL DGEMV( 'Transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), LDA, + $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) + CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, + $ Y( K+1, 1 ), LDY, + $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) + CALL DSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) +* +* Compute T(1:I,I) +* + CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) + CALL DTRMV( 'Upper', 'No Transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, I ), 1 ) + T( I, I ) = TAU( I ) +* + 10 CONTINUE + A( K+NB, NB ) = EI +* +* Compute Y(1:K,1:NB) +* + CALL DLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) + CALL DTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', + $ 'UNIT', K, NB, + $ ONE, A( K+1, 1 ), LDA, Y, LDY ) + IF( N.GT.K+NB ) + $ CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, + $ NB, N-K-NB, ONE, + $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, + $ LDY ) + CALL DTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', + $ 'NON-UNIT', K, NB, + $ ONE, T, LDT, Y, LDY ) +* + RETURN +* +* End of DLAHR2 +* + END diff --git a/2.3-1/src/fortran/lapack/dlahrd.f b/2.3-1/src/fortran/lapack/dlahrd.f new file mode 100644 index 00000000..a04133d1 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlahrd.f @@ -0,0 +1,207 @@ + SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER K, LDA, LDT, LDY, N, NB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), + $ Y( LDY, NB ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION EI +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DLARFG, DSCAL, DTRMV +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* + DO 10 I = 1, NB + IF( I.GT.1 ) THEN +* +* Update A(1:n,i) +* +* Compute i-th column of A - Y * V' +* + CALL DGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, + $ A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 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 +* + CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) + CALL DTRMV( 'Lower', 'Transpose', 'Unit', I-1, A( K+1, 1 ), + $ LDA, T( 1, NB ), 1 ) +* +* w := w + V2'*b2 +* + CALL DGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ), + $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) +* +* w := T'*w +* + CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', I-1, T, LDT, + $ T( 1, NB ), 1 ) +* +* b2 := b2 - V2*w +* + CALL DGEMV( 'No transpose', N-K-I+1, I-1, -ONE, A( K+I, 1 ), + $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) +* +* b1 := b1 - V1*w +* + CALL DTRMV( 'Lower', 'No transpose', 'Unit', I-1, + $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) + CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) +* + A( K+I-1, I-1 ) = EI + END IF +* +* Generate the elementary reflector H(i) to annihilate +* A(k+i+1:n,i) +* + CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, + $ TAU( I ) ) + EI = A( K+I, I ) + A( K+I, I ) = ONE +* +* Compute Y(1:n,i) +* + CALL DGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA, + $ A( K+I, I ), 1, ZERO, Y( 1, I ), 1 ) + CALL DGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ), LDA, + $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) + CALL DGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, T( 1, I ), 1, + $ ONE, Y( 1, I ), 1 ) + CALL DSCAL( N, TAU( I ), Y( 1, I ), 1 ) +* +* Compute T(1:i,i) +* + CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, LDT, + $ T( 1, I ), 1 ) + T( I, I ) = TAU( I ) +* + 10 CONTINUE + A( K+NB, NB ) = EI +* + RETURN +* +* End of DLAHRD +* + END diff --git a/2.3-1/src/fortran/lapack/dlaic1.f b/2.3-1/src/fortran/lapack/dlaic1.f new file mode 100644 index 00000000..44baece1 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlaic1.f @@ -0,0 +1,292 @@ + SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER J, JOB + DOUBLE PRECISION C, GAMMA, S, SEST, SESTPR +* .. +* .. Array Arguments .. + DOUBLE PRECISION W( J ), X( J ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) + DOUBLE PRECISION HALF, FOUR + PARAMETER ( HALF = 0.5D0, FOUR = 4.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION ABSALP, ABSEST, ABSGAM, ALPHA, B, COSINE, EPS, + $ NORMA, S1, S2, SINE, T, TEST, TMP, ZETA1, ZETA2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +* .. +* .. External Functions .. + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL DDOT, DLAMCH +* .. +* .. Executable Statements .. +* + EPS = DLAMCH( 'Epsilon' ) + ALPHA = DDOT( J, X, 1, W, 1 ) +* + ABSALP = ABS( ALPHA ) + ABSGAM = ABS( GAMMA ) + ABSEST = ABS( SEST ) +* + IF( JOB.EQ.1 ) THEN +* +* Estimating largest singular value +* +* special cases +* + IF( SEST.EQ.ZERO ) THEN + S1 = MAX( ABSGAM, ABSALP ) + IF( S1.EQ.ZERO ) THEN + S = ZERO + C = ONE + SESTPR = ZERO + ELSE + S = ALPHA / S1 + C = GAMMA / S1 + TMP = SQRT( S*S+C*C ) + S = S / TMP + C = C / TMP + SESTPR = S1*TMP + END IF + RETURN + ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN + S = ONE + C = ZERO + TMP = MAX( ABSEST, ABSALP ) + S1 = ABSEST / TMP + S2 = ABSALP / TMP + SESTPR = TMP*SQRT( S1*S1+S2*S2 ) + RETURN + ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN + S1 = ABSGAM + S2 = ABSEST + IF( S1.LE.S2 ) THEN + S = ONE + C = ZERO + SESTPR = S2 + ELSE + S = ZERO + C = ONE + SESTPR = S1 + END IF + RETURN + ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN + S1 = ABSGAM + S2 = ABSALP + IF( S1.LE.S2 ) THEN + TMP = S1 / S2 + S = SQRT( ONE+TMP*TMP ) + SESTPR = S2*S + C = ( GAMMA / S2 ) / S + S = SIGN( ONE, ALPHA ) / S + ELSE + TMP = S2 / S1 + C = SQRT( ONE+TMP*TMP ) + SESTPR = S1*C + S = ( ALPHA / S1 ) / C + C = SIGN( ONE, GAMMA ) / C + END IF + RETURN + ELSE +* +* normal case +* + ZETA1 = ALPHA / ABSEST + ZETA2 = GAMMA / ABSEST +* + B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF + C = ZETA1*ZETA1 + IF( B.GT.ZERO ) THEN + T = C / ( B+SQRT( B*B+C ) ) + ELSE + T = SQRT( B*B+C ) - B + END IF +* + SINE = -ZETA1 / T + COSINE = -ZETA2 / ( ONE+T ) + TMP = SQRT( SINE*SINE+COSINE*COSINE ) + S = SINE / TMP + C = COSINE / TMP + SESTPR = SQRT( T+ONE )*ABSEST + RETURN + END IF +* + ELSE IF( JOB.EQ.2 ) THEN +* +* Estimating smallest singular value +* +* special cases +* + IF( SEST.EQ.ZERO ) THEN + SESTPR = ZERO + IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN + SINE = ONE + COSINE = ZERO + ELSE + SINE = -GAMMA + COSINE = ALPHA + END IF + S1 = MAX( ABS( SINE ), ABS( COSINE ) ) + S = SINE / S1 + C = COSINE / S1 + TMP = SQRT( S*S+C*C ) + S = S / TMP + C = C / TMP + RETURN + ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN + S = ZERO + C = ONE + SESTPR = ABSGAM + RETURN + ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN + S1 = ABSGAM + S2 = ABSEST + IF( S1.LE.S2 ) THEN + S = ZERO + C = ONE + SESTPR = S1 + ELSE + S = ONE + C = ZERO + SESTPR = S2 + END IF + RETURN + ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN + S1 = ABSGAM + S2 = ABSALP + IF( S1.LE.S2 ) THEN + TMP = S1 / S2 + C = SQRT( ONE+TMP*TMP ) + SESTPR = ABSEST*( TMP / C ) + S = -( GAMMA / S2 ) / C + C = SIGN( ONE, ALPHA ) / C + ELSE + TMP = S2 / S1 + S = SQRT( ONE+TMP*TMP ) + SESTPR = ABSEST / S + C = ( ALPHA / S1 ) / S + S = -SIGN( ONE, GAMMA ) / S + END IF + RETURN + ELSE +* +* normal case +* + ZETA1 = ALPHA / ABSEST + ZETA2 = GAMMA / ABSEST +* + NORMA = MAX( ONE+ZETA1*ZETA1+ABS( ZETA1*ZETA2 ), + $ ABS( ZETA1*ZETA2 )+ZETA2*ZETA2 ) +* +* See if root is closer to zero or to ONE +* + TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 ) + IF( TEST.GE.ZERO ) THEN +* +* root is close to zero, compute directly +* + B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF + C = ZETA2*ZETA2 + T = C / ( B+SQRT( ABS( B*B-C ) ) ) + SINE = ZETA1 / ( ONE-T ) + COSINE = -ZETA2 / T + SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST + ELSE +* +* root is closer to ONE, shift by that amount +* + B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF + C = ZETA1*ZETA1 + IF( B.GE.ZERO ) THEN + T = -C / ( B+SQRT( B*B+C ) ) + ELSE + T = B - SQRT( B*B+C ) + END IF + SINE = -ZETA1 / T + COSINE = -ZETA2 / ( ONE+T ) + SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST + END IF + TMP = SQRT( SINE*SINE+COSINE*COSINE ) + S = SINE / TMP + C = COSINE / TMP + RETURN +* + END IF + END IF + RETURN +* +* End of DLAIC1 +* + END diff --git a/2.3-1/src/fortran/lapack/dlaisnan.f b/2.3-1/src/fortran/lapack/dlaisnan.f new file mode 100644 index 00000000..96350a27 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlaisnan.f @@ -0,0 +1,41 @@ + LOGICAL FUNCTION DLAISNAN(DIN1,DIN2) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DIN1,DIN2 +* .. +* +* 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. +* +* Strictly speaking, Fortran does not allow aliasing of function +* arguments. So 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 .. + DLAISNAN = (DIN1.NE.DIN2) + RETURN + END diff --git a/2.3-1/src/fortran/lapack/dlaln2.f b/2.3-1/src/fortran/lapack/dlaln2.f new file mode 100644 index 00000000..7c99bdbe --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlaln2.f @@ -0,0 +1,507 @@ + SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, + $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL LTRANS + INTEGER INFO, LDA, LDB, LDX, NA, NW + DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) +* .. +* .. Local Scalars .. + INTEGER ICMAX, J + DOUBLE PRECISION BBND, BI1, BI2, BIGNUM, BNORM, BR1, BR2, CI21, + $ CI22, CMAX, CNORM, CR21, CR22, CSI, CSR, LI21, + $ LR21, SMINI, SMLNUM, TEMP, U22ABS, UI11, UI11R, + $ UI12, UI12S, UI22, UR11, UR11R, UR12, UR12S, + $ UR22, XI1, XI2, XR1, XR2 +* .. +* .. Local Arrays .. + LOGICAL RSWAP( 4 ), ZSWAP( 4 ) + INTEGER IPIVOT( 4, 4 ) + DOUBLE PRECISION CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLADIV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Equivalences .. + EQUIVALENCE ( CI( 1, 1 ), CIV( 1 ) ), + $ ( CR( 1, 1 ), CRV( 1 ) ) +* .. +* .. Data statements .. + DATA ZSWAP / .FALSE., .FALSE., .TRUE., .TRUE. / + DATA RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. / + DATA IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4, + $ 3, 2, 1 / +* .. +* .. Executable Statements .. +* +* Compute BIGNUM +* + SMLNUM = TWO*DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + SMINI = MAX( SMIN, SMLNUM ) +* +* Don't check for input errors +* + INFO = 0 +* +* Standard Initializations +* + SCALE = ONE +* + IF( NA.EQ.1 ) THEN +* +* 1 x 1 (i.e., scalar) system C X = B +* + IF( NW.EQ.1 ) THEN +* +* Real 1x1 system. +* +* C = ca A - w D +* + CSR = CA*A( 1, 1 ) - WR*D1 + CNORM = ABS( CSR ) +* +* If | C | < SMINI, use C = SMINI +* + IF( CNORM.LT.SMINI ) THEN + CSR = SMINI + CNORM = SMINI + INFO = 1 + END IF +* +* Check scaling for X = B / C +* + BNORM = ABS( B( 1, 1 ) ) + IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN + IF( BNORM.GT.BIGNUM*CNORM ) + $ SCALE = ONE / BNORM + END IF +* +* Compute X +* + X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / CSR + XNORM = ABS( X( 1, 1 ) ) + ELSE +* +* Complex 1x1 system (w is complex) +* +* C = ca A - w D +* + CSR = CA*A( 1, 1 ) - WR*D1 + CSI = -WI*D1 + CNORM = ABS( CSR ) + ABS( CSI ) +* +* If | C | < SMINI, use C = SMINI +* + IF( CNORM.LT.SMINI ) THEN + CSR = SMINI + CSI = ZERO + CNORM = SMINI + INFO = 1 + END IF +* +* Check scaling for X = B / C +* + BNORM = ABS( B( 1, 1 ) ) + ABS( B( 1, 2 ) ) + IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN + IF( BNORM.GT.BIGNUM*CNORM ) + $ SCALE = ONE / BNORM + END IF +* +* Compute X +* + CALL DLADIV( SCALE*B( 1, 1 ), SCALE*B( 1, 2 ), CSR, CSI, + $ X( 1, 1 ), X( 1, 2 ) ) + XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) + END IF +* + ELSE +* +* 2x2 System +* +* Compute the real part of C = ca A - w D (or ca A' - w D ) +* + CR( 1, 1 ) = CA*A( 1, 1 ) - WR*D1 + CR( 2, 2 ) = CA*A( 2, 2 ) - WR*D2 + IF( LTRANS ) THEN + CR( 1, 2 ) = CA*A( 2, 1 ) + CR( 2, 1 ) = CA*A( 1, 2 ) + ELSE + CR( 2, 1 ) = CA*A( 2, 1 ) + CR( 1, 2 ) = CA*A( 1, 2 ) + END IF +* + IF( NW.EQ.1 ) THEN +* +* Real 2x2 system (w is real) +* +* Find the largest element in C +* + CMAX = ZERO + ICMAX = 0 +* + DO 10 J = 1, 4 + IF( ABS( CRV( J ) ).GT.CMAX ) THEN + CMAX = ABS( CRV( J ) ) + ICMAX = J + END IF + 10 CONTINUE +* +* If norm(C) < SMINI, use SMINI*identity. +* + IF( CMAX.LT.SMINI ) THEN + BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 2, 1 ) ) ) + IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN + IF( BNORM.GT.BIGNUM*SMINI ) + $ SCALE = ONE / BNORM + END IF + TEMP = SCALE / SMINI + X( 1, 1 ) = TEMP*B( 1, 1 ) + X( 2, 1 ) = TEMP*B( 2, 1 ) + XNORM = TEMP*BNORM + INFO = 1 + RETURN + END IF +* +* Gaussian elimination with complete pivoting. +* + UR11 = CRV( ICMAX ) + CR21 = CRV( IPIVOT( 2, ICMAX ) ) + UR12 = CRV( IPIVOT( 3, ICMAX ) ) + CR22 = CRV( IPIVOT( 4, ICMAX ) ) + UR11R = ONE / UR11 + LR21 = UR11R*CR21 + UR22 = CR22 - UR12*LR21 +* +* If smaller pivot < SMINI, use SMINI +* + IF( ABS( UR22 ).LT.SMINI ) THEN + UR22 = SMINI + INFO = 1 + END IF + IF( RSWAP( ICMAX ) ) THEN + BR1 = B( 2, 1 ) + BR2 = B( 1, 1 ) + ELSE + BR1 = B( 1, 1 ) + BR2 = B( 2, 1 ) + END IF + BR2 = BR2 - LR21*BR1 + BBND = MAX( ABS( BR1*( UR22*UR11R ) ), ABS( BR2 ) ) + IF( BBND.GT.ONE .AND. ABS( UR22 ).LT.ONE ) THEN + IF( BBND.GE.BIGNUM*ABS( UR22 ) ) + $ SCALE = ONE / BBND + END IF +* + XR2 = ( BR2*SCALE ) / UR22 + XR1 = ( SCALE*BR1 )*UR11R - XR2*( UR11R*UR12 ) + IF( ZSWAP( ICMAX ) ) THEN + X( 1, 1 ) = XR2 + X( 2, 1 ) = XR1 + ELSE + X( 1, 1 ) = XR1 + X( 2, 1 ) = XR2 + END IF + XNORM = MAX( ABS( XR1 ), ABS( XR2 ) ) +* +* Further scaling if norm(A) norm(X) > overflow +* + IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN + IF( XNORM.GT.BIGNUM / CMAX ) THEN + TEMP = CMAX / BIGNUM + X( 1, 1 ) = TEMP*X( 1, 1 ) + X( 2, 1 ) = TEMP*X( 2, 1 ) + XNORM = TEMP*XNORM + SCALE = TEMP*SCALE + END IF + END IF + ELSE +* +* Complex 2x2 system (w is complex) +* +* Find the largest element in C +* + CI( 1, 1 ) = -WI*D1 + CI( 2, 1 ) = ZERO + CI( 1, 2 ) = ZERO + CI( 2, 2 ) = -WI*D2 + CMAX = ZERO + ICMAX = 0 +* + DO 20 J = 1, 4 + IF( ABS( CRV( J ) )+ABS( CIV( J ) ).GT.CMAX ) THEN + CMAX = ABS( CRV( J ) ) + ABS( CIV( J ) ) + ICMAX = J + END IF + 20 CONTINUE +* +* If norm(C) < SMINI, use SMINI*identity. +* + IF( CMAX.LT.SMINI ) THEN + BNORM = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ), + $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) ) + IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN + IF( BNORM.GT.BIGNUM*SMINI ) + $ SCALE = ONE / BNORM + END IF + TEMP = SCALE / SMINI + X( 1, 1 ) = TEMP*B( 1, 1 ) + X( 2, 1 ) = TEMP*B( 2, 1 ) + X( 1, 2 ) = TEMP*B( 1, 2 ) + X( 2, 2 ) = TEMP*B( 2, 2 ) + XNORM = TEMP*BNORM + INFO = 1 + RETURN + END IF +* +* Gaussian elimination with complete pivoting. +* + UR11 = CRV( ICMAX ) + UI11 = CIV( ICMAX ) + CR21 = CRV( IPIVOT( 2, ICMAX ) ) + CI21 = CIV( IPIVOT( 2, ICMAX ) ) + UR12 = CRV( IPIVOT( 3, ICMAX ) ) + UI12 = CIV( IPIVOT( 3, ICMAX ) ) + CR22 = CRV( IPIVOT( 4, ICMAX ) ) + CI22 = CIV( IPIVOT( 4, ICMAX ) ) + IF( ICMAX.EQ.1 .OR. ICMAX.EQ.4 ) THEN +* +* Code when off-diagonals of pivoted C are real +* + IF( ABS( UR11 ).GT.ABS( UI11 ) ) THEN + TEMP = UI11 / UR11 + UR11R = ONE / ( UR11*( ONE+TEMP**2 ) ) + UI11R = -TEMP*UR11R + ELSE + TEMP = UR11 / UI11 + UI11R = -ONE / ( UI11*( ONE+TEMP**2 ) ) + UR11R = -TEMP*UI11R + END IF + 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 = ONE / UR11 + UI11R = ZERO + LR21 = CR21*UR11R + LI21 = CI21*UR11R + UR12S = UR12*UR11R + UI12S = UI12*UR11R + UR22 = CR22 - UR12*LR21 + UI12*LI21 + UI22 = -UR12*LI21 - UI12*LR21 + END IF + U22ABS = ABS( UR22 ) + ABS( UI22 ) +* +* If smaller pivot < SMINI, use SMINI +* + IF( U22ABS.LT.SMINI ) THEN + UR22 = SMINI + UI22 = ZERO + INFO = 1 + END IF + IF( RSWAP( ICMAX ) ) THEN + BR2 = B( 1, 1 ) + BR1 = B( 2, 1 ) + BI2 = B( 1, 2 ) + BI1 = B( 2, 2 ) + ELSE + BR1 = B( 1, 1 ) + BR2 = B( 2, 1 ) + BI1 = B( 1, 2 ) + BI2 = B( 2, 2 ) + END IF + BR2 = BR2 - LR21*BR1 + LI21*BI1 + BI2 = BI2 - LI21*BR1 - LR21*BI1 + BBND = MAX( ( ABS( BR1 )+ABS( BI1 ) )* + $ ( U22ABS*( ABS( UR11R )+ABS( UI11R ) ) ), + $ ABS( BR2 )+ABS( BI2 ) ) + IF( BBND.GT.ONE .AND. U22ABS.LT.ONE ) THEN + IF( BBND.GE.BIGNUM*U22ABS ) THEN + SCALE = ONE / BBND + BR1 = SCALE*BR1 + BI1 = SCALE*BI1 + BR2 = SCALE*BR2 + BI2 = SCALE*BI2 + END IF + END IF +* + CALL 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 ) ) THEN + X( 1, 1 ) = XR2 + X( 2, 1 ) = XR1 + X( 1, 2 ) = XI2 + X( 2, 2 ) = XI1 + ELSE + X( 1, 1 ) = XR1 + X( 2, 1 ) = XR2 + X( 1, 2 ) = XI1 + X( 2, 2 ) = XI2 + END IF + XNORM = MAX( ABS( XR1 )+ABS( XI1 ), ABS( XR2 )+ABS( XI2 ) ) +* +* Further scaling if norm(A) norm(X) > overflow +* + IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN + IF( XNORM.GT.BIGNUM / CMAX ) THEN + TEMP = CMAX / BIGNUM + X( 1, 1 ) = TEMP*X( 1, 1 ) + X( 2, 1 ) = TEMP*X( 2, 1 ) + X( 1, 2 ) = TEMP*X( 1, 2 ) + X( 2, 2 ) = TEMP*X( 2, 2 ) + XNORM = TEMP*XNORM + SCALE = TEMP*SCALE + END IF + END IF + END IF + END IF +* + RETURN +* +* End of DLALN2 +* + END diff --git a/2.3-1/src/fortran/lapack/dlamch.f b/2.3-1/src/fortran/lapack/dlamch.f new file mode 100644 index 00000000..64ac3bec --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlamch.f @@ -0,0 +1,857 @@ + DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + CHARACTER CMACH +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL FIRST, LRND + INTEGER BETA, IMAX, IMIN, IT + DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, + $ RND, SFMIN, SMALL, T +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLAMC2 +* .. +* .. Save statement .. + SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, + $ EMAX, RMAX, PREC +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) + BASE = BETA + T = IT + IF( LRND ) THEN + RND = ONE + EPS = ( BASE**( 1-IT ) ) / 2 + ELSE + RND = ZERO + EPS = BASE**( 1-IT ) + END IF + PREC = EPS*BASE + EMIN = IMIN + EMAX = IMAX + SFMIN = RMIN + SMALL = ONE / RMAX + IF( SMALL.GE.SFMIN ) THEN +* +* Use SMALL plus a bit, to avoid the possibility of rounding +* causing overflow when computing 1/sfmin. +* + SFMIN = SMALL*( ONE+EPS ) + END IF + END IF +* + IF( LSAME( CMACH, 'E' ) ) THEN + RMACH = EPS + ELSE IF( LSAME( CMACH, 'S' ) ) THEN + RMACH = SFMIN + ELSE IF( LSAME( CMACH, 'B' ) ) THEN + RMACH = BASE + ELSE IF( LSAME( CMACH, 'P' ) ) THEN + RMACH = PREC + ELSE IF( LSAME( CMACH, 'N' ) ) THEN + RMACH = T + ELSE IF( LSAME( CMACH, 'R' ) ) THEN + RMACH = RND + ELSE IF( LSAME( CMACH, 'M' ) ) THEN + RMACH = EMIN + ELSE IF( LSAME( CMACH, 'U' ) ) THEN + RMACH = RMIN + ELSE IF( LSAME( CMACH, 'L' ) ) THEN + RMACH = EMAX + ELSE IF( LSAME( CMACH, 'O' ) ) THEN + RMACH = RMAX + END IF +* + DLAMCH = RMACH + RETURN +* +* End of DLAMCH +* + END +* +************************************************************************ +* + SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + LOGICAL IEEE1, RND + INTEGER BETA, T +* .. +* +* 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 .. + LOGICAL FIRST, LIEEE1, LRND + INTEGER LBETA, LT + DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Save statement .. + SAVE FIRST, LIEEE1, LBETA, LRND, LT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + 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 + 10 CONTINUE + IF( C.EQ.ONE ) THEN + A = 2*A + C = DLAMC3( A, ONE ) + C = DLAMC3( C, -A ) + GO TO 10 + END IF +*+ 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 + 20 CONTINUE + IF( C.EQ.A ) THEN + B = 2*B + C = DLAMC3( A, B ) + GO TO 20 + END IF +*+ 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 + C = DLAMC3( C, -A ) + 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 = LBETA + F = DLAMC3( B / 2, -B / 100 ) + C = DLAMC3( F, A ) + IF( C.EQ.A ) THEN + LRND = .TRUE. + ELSE + LRND = .FALSE. + END IF + F = DLAMC3( B / 2, B / 100 ) + C = DLAMC3( F, A ) + IF( ( LRND ) .AND. ( C.EQ.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. +* + T1 = DLAMC3( B / 2, A ) + T2 = DLAMC3( B / 2, SAVEC ) + LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. 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 + 30 CONTINUE + IF( C.EQ.ONE ) THEN + LT = LT + 1 + A = A*LBETA + C = DLAMC3( A, ONE ) + C = DLAMC3( C, -A ) + GO TO 30 + END IF +*+ END WHILE +* + END IF +* + BETA = LBETA + T = LT + RND = LRND + IEEE1 = LIEEE1 + RETURN +* +* End of DLAMC1 +* + END +* +************************************************************************ +* + SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + LOGICAL RND + INTEGER BETA, EMAX, EMIN, T + DOUBLE PRECISION EPS, RMAX, RMIN +* .. +* +* 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 .. + LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND + INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, + $ NGNMIN, NGPMIN + DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, + $ SIXTH, SMALL, THIRD, TWO, ZERO +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. External Subroutines .. + EXTERNAL DLAMC1, DLAMC4, DLAMC5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Save statement .. + SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, + $ LRMIN, LT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / , IWARN / .FALSE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + 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. +* + CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) +* +* Start to find EPS. +* + B = LBETA + A = B**( -LT ) + LEPS = A +* +* Try some tricks to see whether or not this is the correct EPS. +* + B = TWO / 3 + HALF = ONE / 2 + SIXTH = DLAMC3( B, -HALF ) + THIRD = DLAMC3( SIXTH, SIXTH ) + B = DLAMC3( THIRD, -HALF ) + B = DLAMC3( B, SIXTH ) + B = ABS( B ) + IF( B.LT.LEPS ) + $ B = LEPS +* + LEPS = 1 +* +*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP + 10 CONTINUE + IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN + LEPS = B + C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) + C = DLAMC3( HALF, -C ) + B = DLAMC3( HALF, C ) + C = DLAMC3( HALF, -B ) + B = DLAMC3( HALF, C ) + GO TO 10 + END IF +*+ END WHILE +* + IF( A.LT.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 + DO 20 I = 1, 3 + SMALL = DLAMC3( SMALL*RBASE, ZERO ) + 20 CONTINUE + A = DLAMC3( ONE, SMALL ) + CALL DLAMC4( NGPMIN, ONE, LBETA ) + CALL DLAMC4( NGNMIN, -ONE, LBETA ) + CALL DLAMC4( GPMIN, A, LBETA ) + CALL DLAMC4( GNMIN, -A, LBETA ) + IEEE = .FALSE. +* + IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN + IF( NGPMIN.EQ.GPMIN ) THEN + LEMIN = NGPMIN +* ( Non twos-complement machines, no gradual underflow; +* e.g., VAX ) + ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN + 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. + END IF +* + ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN + IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN + 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. + END IF +* + ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. + $ ( GPMIN.EQ.GNMIN ) ) THEN + IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN + 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. + END IF +* + ELSE + LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +*** +* Comment out this if block if EMIN is ok + IF( IWARN ) THEN + FIRST = .TRUE. + WRITE( 6, FMT = 9999 )LEMIN + END IF +*** +* +* 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 .OR. 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 + DO 30 I = 1, 1 - LEMIN + LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) + 30 CONTINUE +* +* Finally, call DLAMC5 to compute EMAX and RMAX. +* + CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) + END IF +* + BETA = LBETA + T = LT + RND = LRND + EPS = LEPS + EMIN = LEMIN + RMIN = LRMIN + EMAX = LEMAX + RMAX = LRMAX +* + RETURN +* + 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', + $ ' EMIN = ', I8, / + $ ' If, after inspection, the value EMIN looks', + $ ' acceptable please comment out ', + $ / ' the IF block as marked within the code of routine', + $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) +* +* End of DLAMC2 +* + END +* +************************************************************************ +* + DOUBLE PRECISION FUNCTION DLAMC3( A, B ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B +* .. +* +* 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, B (input) DOUBLE PRECISION +* The values A and B. +* +* ===================================================================== +* +* .. Executable Statements .. +* + DLAMC3 = A + B +* + RETURN +* +* End of DLAMC3 +* + END +* +************************************************************************ +* + SUBROUTINE DLAMC4( EMIN, START, BASE ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + INTEGER BASE, EMIN + DOUBLE PRECISION START +* .. +* +* Purpose +* ======= +* +* DLAMC4 is a service routine for DLAMC2. +* +* Arguments +* ========= +* +* EMIN (output) EMIN +* 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 .. + INTEGER I + DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Executable Statements .. +* + A = START + ONE = 1 + RBASE = ONE / BASE + ZERO = 0 + EMIN = 1 + B1 = DLAMC3( A*RBASE, 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 + 10 CONTINUE + IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. + $ ( D2.EQ.A ) ) THEN + EMIN = EMIN - 1 + A = B1 + B1 = DLAMC3( A / BASE, ZERO ) + C1 = DLAMC3( B1*BASE, ZERO ) + D1 = ZERO + DO 20 I = 1, BASE + D1 = D1 + B1 + 20 CONTINUE + B2 = DLAMC3( A*RBASE, ZERO ) + C2 = DLAMC3( B2 / RBASE, ZERO ) + D2 = ZERO + DO 30 I = 1, BASE + D2 = D2 + B2 + 30 CONTINUE + GO TO 10 + END IF +*+ END WHILE +* + RETURN +* +* End of DLAMC4 +* + END +* +************************************************************************ +* + SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER BETA, EMAX, EMIN, P + DOUBLE PRECISION RMAX +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP + DOUBLE PRECISION OLDY, RECBAS, Y, Z +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. 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 + 10 CONTINUE + TRY = LEXP*2 + IF( TRY.LE.( -EMIN ) ) THEN + LEXP = TRY + EXBITS = EXBITS + 1 + GO TO 10 + END IF + IF( LEXP.EQ.-EMIN ) THEN + UEXP = LEXP + ELSE + UEXP = TRY + EXBITS = EXBITS + 1 + END IF +* +* 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 ).GT.( -LEXP-EMIN ) ) THEN + EXPSUM = 2*LEXP + ELSE + EXPSUM = 2*UEXP + END IF +* +* EXPSUM is the exponent range, approximately equal to +* EMAX - EMIN + 1 . +* + EMAX = EXPSUM + EMIN - 1 + NBITS = 1 + EXBITS + P +* +* NBITS is the total number of bits needed to store a +* floating-point number. +* + IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN +* +* 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 = EMAX - 1 + END IF +* + IF( IEEE ) THEN +* +* Assume we are on an IEEE machine which reserves one exponent +* for infinity and NaN. +* + EMAX = EMAX - 1 + END IF +* +* 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 = ONE / BETA + Z = BETA - ONE + Y = ZERO + DO 20 I = 1, P + Z = Z*RECBAS + IF( Y.LT.ONE ) + $ OLDY = Y + Y = DLAMC3( Y, Z ) + 20 CONTINUE + IF( Y.GE.ONE ) + $ Y = OLDY +* +* Now multiply by BETA**EMAX to get RMAX. +* + DO 30 I = 1, EMAX + Y = DLAMC3( Y*BETA, ZERO ) + 30 CONTINUE +* + RMAX = Y + RETURN +* +* End of DLAMC5 +* + END diff --git a/2.3-1/src/fortran/lapack/dlange.f b/2.3-1/src/fortran/lapack/dlange.f new file mode 100644 index 00000000..fec96ac7 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlange.f @@ -0,0 +1,144 @@ + DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION SCALE, SUM, VALUE +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + IF( MIN( M, N ).EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + VALUE = ZERO + DO 20 J = 1, N + DO 10 I = 1, M + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 10 CONTINUE + 20 CONTINUE + ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN +* +* Find norm1(A). +* + VALUE = ZERO + DO 40 J = 1, N + SUM = ZERO + DO 30 I = 1, M + SUM = SUM + ABS( A( I, J ) ) + 30 CONTINUE + VALUE = MAX( VALUE, SUM ) + 40 CONTINUE + ELSE IF( LSAME( NORM, 'I' ) ) THEN +* +* Find normI(A). +* + DO 50 I = 1, M + WORK( I ) = ZERO + 50 CONTINUE + DO 70 J = 1, N + DO 60 I = 1, M + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) + 60 CONTINUE + 70 CONTINUE + VALUE = ZERO + DO 80 I = 1, M + VALUE = MAX( VALUE, WORK( I ) ) + 80 CONTINUE + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + DO 90 J = 1, N + CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM ) + 90 CONTINUE + VALUE = SCALE*SQRT( SUM ) + END IF +* + DLANGE = VALUE + RETURN +* +* End of DLANGE +* + END diff --git a/2.3-1/src/fortran/lapack/dlanhs.f b/2.3-1/src/fortran/lapack/dlanhs.f new file mode 100644 index 00000000..76b87eeb --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlanhs.f @@ -0,0 +1,141 @@ + DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION SCALE, SUM, VALUE +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + IF( N.EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + VALUE = ZERO + DO 20 J = 1, N + DO 10 I = 1, MIN( N, J+1 ) + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 10 CONTINUE + 20 CONTINUE + ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN +* +* Find norm1(A). +* + VALUE = ZERO + DO 40 J = 1, N + SUM = ZERO + DO 30 I = 1, MIN( N, J+1 ) + SUM = SUM + ABS( A( I, J ) ) + 30 CONTINUE + VALUE = MAX( VALUE, SUM ) + 40 CONTINUE + ELSE IF( LSAME( NORM, 'I' ) ) THEN +* +* Find normI(A). +* + DO 50 I = 1, N + WORK( I ) = ZERO + 50 CONTINUE + DO 70 J = 1, N + DO 60 I = 1, MIN( N, J+1 ) + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) + 60 CONTINUE + 70 CONTINUE + VALUE = ZERO + DO 80 I = 1, N + VALUE = MAX( VALUE, WORK( I ) ) + 80 CONTINUE + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + DO 90 J = 1, N + CALL DLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) + 90 CONTINUE + VALUE = SCALE*SQRT( SUM ) + END IF +* + DLANHS = VALUE + RETURN +* +* End of DLANHS +* + END diff --git a/2.3-1/src/fortran/lapack/dlansp.f b/2.3-1/src/fortran/lapack/dlansp.f new file mode 100644 index 00000000..ab221006 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlansp.f @@ -0,0 +1,196 @@ + DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER NORM, UPLO + INTEGER N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, K + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* + IF( N.EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + K = 1 + DO 20 J = 1, N + DO 10 I = K, K + J - 1 + VALUE = MAX( VALUE, ABS( AP( I ) ) ) + 10 CONTINUE + K = K + J + 20 CONTINUE + ELSE + K = 1 + DO 40 J = 1, N + DO 30 I = K, K + N - J + VALUE = MAX( VALUE, ABS( AP( I ) ) ) + 30 CONTINUE + K = K + N - J + 1 + 40 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. + $ ( NORM.EQ.'1' ) ) THEN +* +* Find normI(A) ( = norm1(A), since A is symmetric). +* + VALUE = ZERO + K = 1 + IF( LSAME( UPLO, 'U' ) ) THEN + DO 60 J = 1, N + SUM = ZERO + DO 50 I = 1, J - 1 + ABSA = ABS( AP( K ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + K = K + 1 + 50 CONTINUE + WORK( J ) = SUM + ABS( AP( K ) ) + K = K + 1 + 60 CONTINUE + DO 70 I = 1, N + VALUE = MAX( VALUE, WORK( I ) ) + 70 CONTINUE + ELSE + DO 80 I = 1, N + WORK( I ) = ZERO + 80 CONTINUE + DO 100 J = 1, N + SUM = WORK( J ) + ABS( AP( K ) ) + K = K + 1 + DO 90 I = J + 1, N + ABSA = ABS( AP( K ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + K = K + 1 + 90 CONTINUE + VALUE = MAX( VALUE, SUM ) + 100 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + K = 2 + IF( LSAME( UPLO, 'U' ) ) THEN + DO 110 J = 2, N + CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM ) + K = K + J + 110 CONTINUE + ELSE + DO 120 J = 1, N - 1 + CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM ) + K = K + N - J + 1 + 120 CONTINUE + END IF + SUM = 2*SUM + K = 1 + DO 130 I = 1, N + IF( AP( K ).NE.ZERO ) THEN + ABSA = ABS( AP( K ) ) + IF( SCALE.LT.ABSA ) THEN + SUM = ONE + SUM*( SCALE / ABSA )**2 + SCALE = ABSA + ELSE + SUM = SUM + ( ABSA / SCALE )**2 + END IF + END IF + IF( LSAME( UPLO, 'U' ) ) THEN + K = K + I + 1 + ELSE + K = K + N - I + 1 + END IF + 130 CONTINUE + VALUE = SCALE*SQRT( SUM ) + END IF +* + DLANSP = VALUE + RETURN +* +* End of DLANSP +* + END diff --git a/2.3-1/src/fortran/lapack/dlanst.f b/2.3-1/src/fortran/lapack/dlanst.f new file mode 100644 index 00000000..2b12091a --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlanst.f @@ -0,0 +1,124 @@ + DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION ANORM, SCALE, SUM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* + IF( N.LE.0 ) THEN + ANORM = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + ANORM = ABS( D( N ) ) + DO 10 I = 1, N - 1 + ANORM = MAX( ANORM, ABS( D( I ) ) ) + ANORM = MAX( ANORM, ABS( E( I ) ) ) + 10 CONTINUE + ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. + $ LSAME( NORM, 'I' ) ) THEN +* +* Find norm1(A). +* + IF( N.EQ.1 ) THEN + ANORM = ABS( D( 1 ) ) + ELSE + ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), + $ ABS( E( N-1 ) )+ABS( D( N ) ) ) + DO 20 I = 2, N - 1 + ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+ + $ ABS( E( I-1 ) ) ) + 20 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + IF( N.GT.1 ) THEN + CALL DLASSQ( N-1, E, 1, SCALE, SUM ) + SUM = 2*SUM + END IF + CALL DLASSQ( N, D, 1, SCALE, SUM ) + ANORM = SCALE*SQRT( SUM ) + END IF +* + DLANST = ANORM + RETURN +* +* End of DLANST +* + END diff --git a/2.3-1/src/fortran/lapack/dlansy.f b/2.3-1/src/fortran/lapack/dlansy.f new file mode 100644 index 00000000..b6c727c0 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlansy.f @@ -0,0 +1,173 @@ + DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER NORM, UPLO + INTEGER LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* + IF( N.EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, J + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J, N + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. + $ ( NORM.EQ.'1' ) ) THEN +* +* Find normI(A) ( = norm1(A), since A is symmetric). +* + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 60 J = 1, N + SUM = ZERO + DO 50 I = 1, J - 1 + ABSA = ABS( A( I, J ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + 50 CONTINUE + WORK( J ) = SUM + ABS( A( J, J ) ) + 60 CONTINUE + DO 70 I = 1, N + VALUE = MAX( VALUE, WORK( I ) ) + 70 CONTINUE + ELSE + DO 80 I = 1, N + WORK( I ) = ZERO + 80 CONTINUE + DO 100 J = 1, N + SUM = WORK( J ) + ABS( A( J, J ) ) + DO 90 I = J + 1, N + ABSA = ABS( A( I, J ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + 90 CONTINUE + VALUE = MAX( VALUE, SUM ) + 100 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + IF( LSAME( UPLO, 'U' ) ) THEN + DO 110 J = 2, N + CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) + 110 CONTINUE + ELSE + DO 120 J = 1, N - 1 + CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) + 120 CONTINUE + END IF + SUM = 2*SUM + CALL DLASSQ( N, A, LDA+1, SCALE, SUM ) + VALUE = SCALE*SQRT( SUM ) + END IF +* + DLANSY = VALUE + RETURN +* +* End of DLANSY +* + END diff --git a/2.3-1/src/fortran/lapack/dlantr.f b/2.3-1/src/fortran/lapack/dlantr.f new file mode 100644 index 00000000..92debd3d --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlantr.f @@ -0,0 +1,276 @@ + DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, + $ WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIAG, NORM, UPLO + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UDIAG + INTEGER I, J + DOUBLE PRECISION SCALE, SUM, VALUE +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + IF( MIN( M, N ).EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + IF( LSAME( DIAG, 'U' ) ) THEN + VALUE = ONE + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, MIN( M, J-1 ) + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J + 1, M + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 60 J = 1, N + DO 50 I = 1, MIN( M, J ) + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1, N + DO 70 I = J, M + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN +* +* Find norm1(A). +* + VALUE = ZERO + UDIAG = LSAME( DIAG, 'U' ) + IF( LSAME( UPLO, 'U' ) ) THEN + DO 110 J = 1, N + IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN + SUM = ONE + DO 90 I = 1, J - 1 + SUM = SUM + ABS( A( I, J ) ) + 90 CONTINUE + ELSE + SUM = ZERO + DO 100 I = 1, MIN( M, J ) + SUM = SUM + ABS( A( I, J ) ) + 100 CONTINUE + END IF + VALUE = MAX( VALUE, SUM ) + 110 CONTINUE + ELSE + DO 140 J = 1, N + IF( UDIAG ) THEN + SUM = ONE + DO 120 I = J + 1, M + SUM = SUM + ABS( A( I, J ) ) + 120 CONTINUE + ELSE + SUM = ZERO + DO 130 I = J, M + SUM = SUM + ABS( A( I, J ) ) + 130 CONTINUE + END IF + VALUE = MAX( VALUE, SUM ) + 140 CONTINUE + END IF + ELSE IF( LSAME( NORM, 'I' ) ) THEN +* +* Find normI(A). +* + IF( LSAME( UPLO, 'U' ) ) THEN + IF( LSAME( DIAG, 'U' ) ) THEN + DO 150 I = 1, M + WORK( I ) = ONE + 150 CONTINUE + DO 170 J = 1, N + DO 160 I = 1, MIN( M, J-1 ) + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) + 160 CONTINUE + 170 CONTINUE + ELSE + DO 180 I = 1, M + WORK( I ) = ZERO + 180 CONTINUE + DO 200 J = 1, N + DO 190 I = 1, MIN( M, J ) + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) + 190 CONTINUE + 200 CONTINUE + END IF + ELSE + IF( LSAME( DIAG, 'U' ) ) THEN + DO 210 I = 1, N + WORK( I ) = ONE + 210 CONTINUE + DO 220 I = N + 1, M + WORK( I ) = ZERO + 220 CONTINUE + DO 240 J = 1, N + DO 230 I = J + 1, M + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) + 230 CONTINUE + 240 CONTINUE + ELSE + DO 250 I = 1, M + WORK( I ) = ZERO + 250 CONTINUE + DO 270 J = 1, N + DO 260 I = J, M + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) + 260 CONTINUE + 270 CONTINUE + END IF + END IF + VALUE = ZERO + DO 280 I = 1, M + VALUE = MAX( VALUE, WORK( I ) ) + 280 CONTINUE + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + IF( LSAME( UPLO, 'U' ) ) THEN + IF( LSAME( DIAG, 'U' ) ) THEN + SCALE = ONE + SUM = MIN( M, N ) + DO 290 J = 2, N + CALL DLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM ) + 290 CONTINUE + ELSE + SCALE = ZERO + SUM = ONE + DO 300 J = 1, N + CALL DLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM ) + 300 CONTINUE + END IF + ELSE + IF( LSAME( DIAG, 'U' ) ) THEN + SCALE = ONE + SUM = MIN( M, N ) + DO 310 J = 1, N + CALL DLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE, + $ SUM ) + 310 CONTINUE + ELSE + SCALE = ZERO + SUM = ONE + DO 320 J = 1, N + CALL DLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM ) + 320 CONTINUE + END IF + END IF + VALUE = SCALE*SQRT( SUM ) + END IF +* + DLANTR = VALUE + RETURN +* +* End of DLANTR +* + END diff --git a/2.3-1/src/fortran/lapack/dlanv2.f b/2.3-1/src/fortran/lapack/dlanv2.f new file mode 100644 index 00000000..cef3f472 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlanv2.f @@ -0,0 +1,205 @@ + SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION MULTPL + PARAMETER ( MULTPL = 4.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB, + $ SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SIGN, SQRT +* .. +* .. Executable Statements .. +* + EPS = DLAMCH( 'P' ) + IF( C.EQ.ZERO ) THEN + CS = ONE + SN = ZERO + GO TO 10 +* + ELSE IF( B.EQ.ZERO ) THEN +* +* Swap rows and columns +* + CS = ZERO + SN = ONE + TEMP = D + D = A + A = TEMP + B = -C + C = ZERO + GO TO 10 + ELSE IF( ( A-D ).EQ.ZERO .AND. SIGN( ONE, B ).NE.SIGN( ONE, C ) ) + $ THEN + CS = ONE + SN = ZERO + GO TO 10 + ELSE +* + TEMP = A - D + P = HALF*TEMP + BCMAX = MAX( ABS( B ), ABS( C ) ) + BCMIS = MIN( ABS( B ), ABS( C ) )*SIGN( ONE, B )*SIGN( ONE, C ) + SCALE = MAX( ABS( P ), 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.GE.MULTPL*EPS ) THEN +* +* Real eigenvalues. Compute A and D. +* + Z = P + SIGN( SQRT( SCALE )*SQRT( Z ), P ) + A = D + Z + D = D - ( BCMAX / Z )*BCMIS +* +* Compute B and the rotation matrix +* + TAU = DLAPY2( C, Z ) + CS = Z / TAU + SN = C / TAU + B = B - C + C = ZERO + ELSE +* +* Complex eigenvalues, or real (almost) equal eigenvalues. +* Make diagonal elements equal. +* + SIGMA = B + C + TAU = DLAPY2( SIGMA, TEMP ) + CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) ) + SN = -( P / ( TAU*CS ) )*SIGN( ONE, 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 = HALF*( A+D ) + A = TEMP + D = TEMP +* + IF( C.NE.ZERO ) THEN + IF( B.NE.ZERO ) THEN + IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN +* +* Real eigenvalues: reduce to upper triangular form +* + SAB = SQRT( ABS( B ) ) + SAC = SQRT( ABS( C ) ) + P = SIGN( SAB*SAC, C ) + TAU = ONE / SQRT( ABS( B+C ) ) + A = TEMP + P + D = TEMP - P + B = B - C + C = ZERO + CS1 = SAB*TAU + SN1 = SAC*TAU + TEMP = CS*CS1 - SN*SN1 + SN = CS*SN1 + SN*CS1 + CS = TEMP + END IF + ELSE + B = -C + C = ZERO + TEMP = CS + CS = -SN + SN = TEMP + END IF + END IF + END IF +* + END IF +* + 10 CONTINUE +* +* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). +* + RT1R = A + RT2R = D + IF( C.EQ.ZERO ) THEN + RT1I = ZERO + RT2I = ZERO + ELSE + RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) ) + RT2I = -RT1I + END IF + RETURN +* +* End of DLANV2 +* + END diff --git a/2.3-1/src/fortran/lapack/dlapmt.f b/2.3-1/src/fortran/lapack/dlapmt.f new file mode 100644 index 00000000..325774c0 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlapmt.f @@ -0,0 +1,136 @@ + SUBROUTINE DLAPMT( FORWRD, M, N, X, LDX, K ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL FORWRD + INTEGER LDX, M, N +* .. +* .. Array Arguments .. + INTEGER K( * ) + DOUBLE PRECISION X( LDX, * ) +* .. +* +* 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 .. + INTEGER I, II, IN, J + DOUBLE PRECISION TEMP +* .. +* .. Executable Statements .. +* + IF( N.LE.1 ) + $ RETURN +* + DO 10 I = 1, N + K( I ) = -K( I ) + 10 CONTINUE +* + IF( FORWRD ) THEN +* +* Forward permutation +* + DO 50 I = 1, N +* + IF( K( I ).GT.0 ) + $ GO TO 40 +* + J = I + K( J ) = -K( J ) + IN = K( J ) +* + 20 CONTINUE + IF( K( IN ).GT.0 ) + $ GO TO 40 +* + DO 30 II = 1, M + TEMP = X( II, J ) + X( II, J ) = X( II, IN ) + X( II, IN ) = TEMP + 30 CONTINUE +* + K( IN ) = -K( IN ) + J = IN + IN = K( IN ) + GO TO 20 +* + 40 CONTINUE +* + 50 CONTINUE +* + ELSE +* +* Backward permutation +* + DO 90 I = 1, N +* + IF( K( I ).GT.0 ) + $ GO TO 80 +* + K( I ) = -K( I ) + J = K( I ) + 60 CONTINUE + IF( J.EQ.I ) + $ GO TO 80 +* + DO 70 II = 1, M + TEMP = X( II, I ) + X( II, I ) = X( II, J ) + X( II, J ) = TEMP + 70 CONTINUE +* + K( J ) = -K( J ) + J = K( J ) + GO TO 60 +* + 80 CONTINUE +* + 90 CONTINUE +* + END IF +* + RETURN +* +* End of DLAPMT +* + END diff --git a/2.3-1/src/fortran/lapack/dlapy2.f b/2.3-1/src/fortran/lapack/dlapy2.f new file mode 100644 index 00000000..98ef81b6 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlapy2.f @@ -0,0 +1,53 @@ + DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION W, XABS, YABS, Z +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + XABS = ABS( X ) + YABS = ABS( Y ) + W = MAX( XABS, YABS ) + Z = MIN( XABS, YABS ) + IF( Z.EQ.ZERO ) THEN + DLAPY2 = W + ELSE + DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) + END IF + RETURN +* +* End of DLAPY2 +* + END diff --git a/2.3-1/src/fortran/lapack/dlapy3.f b/2.3-1/src/fortran/lapack/dlapy3.f new file mode 100644 index 00000000..2b47bb47 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlapy3.f @@ -0,0 +1,56 @@ + DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y, Z +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION W, XABS, YABS, ZABS +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* + XABS = ABS( X ) + YABS = ABS( Y ) + ZABS = ABS( Z ) + W = MAX( XABS, YABS, ZABS ) + IF( W.EQ.ZERO ) THEN +* W can be zero for max(0,nan,0) +* adding all three entries together will make sure +* NaN will not disappear. + DLAPY3 = XABS + YABS + ZABS + ELSE + DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ + $ ( ZABS / W )**2 ) + END IF + RETURN +* +* End of DLAPY3 +* + END diff --git a/2.3-1/src/fortran/lapack/dlaqge.f b/2.3-1/src/fortran/lapack/dlaqge.f new file mode 100644 index 00000000..9feb927c --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlaqge.f @@ -0,0 +1,154 @@ + SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ EQUED ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER EQUED + INTEGER LDA, M, N + DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, THRESH + PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION CJ, LARGE, SMALL +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) THEN + EQUED = 'N' + RETURN + END IF +* +* Initialize LARGE and SMALL. +* + SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + LARGE = ONE / SMALL +* + IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) + $ THEN +* +* No row scaling +* + IF( COLCND.GE.THRESH ) THEN +* +* No column scaling +* + EQUED = 'N' + ELSE +* +* Column scaling +* + DO 20 J = 1, N + CJ = C( J ) + DO 10 I = 1, M + A( I, J ) = CJ*A( I, J ) + 10 CONTINUE + 20 CONTINUE + EQUED = 'C' + END IF + ELSE IF( COLCND.GE.THRESH ) THEN +* +* Row scaling, no column scaling +* + DO 40 J = 1, N + DO 30 I = 1, M + A( I, J ) = R( I )*A( I, J ) + 30 CONTINUE + 40 CONTINUE + EQUED = 'R' + ELSE +* +* Row and column scaling +* + DO 60 J = 1, N + CJ = C( J ) + DO 50 I = 1, M + A( I, J ) = CJ*R( I )*A( I, J ) + 50 CONTINUE + 60 CONTINUE + EQUED = 'B' + END IF +* + RETURN +* +* End of DLAQGE +* + END diff --git a/2.3-1/src/fortran/lapack/dlaqp2.f b/2.3-1/src/fortran/lapack/dlaqp2.f new file mode 100644 index 00000000..5ce3b162 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlaqp2.f @@ -0,0 +1,175 @@ + SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, + $ WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER LDA, M, N, OFFSET +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), + $ WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, MN, OFFPI, PVT + DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 +* .. +* .. Executable Statements .. +* + MN = MIN( M-OFFSET, N ) + TOL3Z = SQRT(DLAMCH('Epsilon')) +* +* Compute factorization. +* + DO 20 I = 1, MN +* + OFFPI = OFFSET + I +* +* Determine ith pivot column and swap if necessary. +* + PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 ) +* + IF( PVT.NE.I ) THEN + CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( I ) + JPVT( I ) = ITEMP + VN1( PVT ) = VN1( I ) + VN2( PVT ) = VN2( I ) + END IF +* +* Generate elementary reflector H(i). +* + IF( OFFPI.LT.M ) THEN + CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, + $ TAU( I ) ) + ELSE + CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) + END IF +* + IF( I.LT.N ) THEN +* +* Apply H(i)' to A(offset+i:m,i+1:n) from the left. +* + AII = A( OFFPI, I ) + A( OFFPI, I ) = ONE + CALL DLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, + $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) + A( OFFPI, I ) = AII + END IF +* +* Update partial column norms. +* + DO 10 J = I + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following 4 lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN + IF( OFFPI.LT.M ) THEN + VN1( J ) = DNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) + VN2( J ) = VN1( J ) + ELSE + VN1( J ) = ZERO + VN2( J ) = ZERO + END IF + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + 10 CONTINUE +* + 20 CONTINUE +* + RETURN +* +* End of DLAQP2 +* + END diff --git a/2.3-1/src/fortran/lapack/dlaqps.f b/2.3-1/src/fortran/lapack/dlaqps.f new file mode 100644 index 00000000..94658d27 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlaqps.f @@ -0,0 +1,259 @@ + SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, + $ VN2, AUXV, F, LDF ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER KB, LDA, LDF, M, N, NB, OFFSET +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), + $ VN1( * ), VN2( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK + DOUBLE PRECISION AKK, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, NINT, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 +* .. +* .. Executable Statements .. +* + LASTRK = MIN( M, N+OFFSET ) + LSTICC = 0 + K = 0 + TOL3Z = SQRT(DLAMCH('Epsilon')) +* +* Beginning of while loop. +* + 10 CONTINUE + IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN + K = K + 1 + RK = OFFSET + K +* +* Determine ith pivot column and swap if necessary +* + PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) + IF( PVT.NE.K ) THEN + CALL DSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 ) + CALL DSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( K ) + JPVT( K ) = ITEMP + VN1( PVT ) = VN1( K ) + VN2( PVT ) = VN2( K ) + END IF +* +* 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.GT.1 ) THEN + CALL DGEMV( 'No transpose', M-RK+1, K-1, -ONE, A( RK, 1 ), + $ LDA, F( K, 1 ), LDF, ONE, A( RK, K ), 1 ) + END IF +* +* Generate elementary reflector H(k). +* + IF( RK.LT.M ) THEN + CALL DLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) + ELSE + CALL DLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) + END IF +* + AKK = A( RK, K ) + A( RK, K ) = ONE +* +* 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.LT.N ) THEN + CALL DGEMV( 'Transpose', M-RK+1, N-K, TAU( K ), + $ A( RK, K+1 ), LDA, A( RK, K ), 1, ZERO, + $ F( K+1, K ), 1 ) + END IF +* +* Padding F(1:K,K) with zeros. +* + DO 20 J = 1, K + F( J, K ) = ZERO + 20 CONTINUE +* +* 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.GT.1 ) THEN + CALL DGEMV( 'Transpose', M-RK+1, K-1, -TAU( K ), A( RK, 1 ), + $ LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 ) +* + CALL DGEMV( 'No transpose', N, K-1, ONE, F( 1, 1 ), LDF, + $ AUXV( 1 ), 1, ONE, F( 1, K ), 1 ) + END IF +* +* 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.LT.N ) THEN + CALL DGEMV( 'No transpose', N-K, K, -ONE, F( K+1, 1 ), LDF, + $ A( RK, 1 ), LDA, ONE, A( RK, K+1 ), LDA ) + END IF +* +* Update partial column norms. +* + IF( RK.LT.LASTRK ) THEN + DO 30 J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following 4 lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ABS( A( RK, J ) ) / VN1( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN + VN2( J ) = DBLE( LSTICC ) + LSTICC = J + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE + END IF +* + A( RK, K ) = AKK +* +* End of while loop. +* + GO TO 10 + END IF + 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)'. +* + IF( KB.LT.MIN( N, M-OFFSET ) ) THEN + CALL DGEMM( 'No transpose', 'Transpose', M-RK, N-KB, KB, -ONE, + $ A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, + $ A( RK+1, KB+1 ), LDA ) + END IF +* +* Recomputation of difficult columns. +* + 40 CONTINUE + IF( LSTICC.GT.0 ) THEN + ITEMP = NINT( VN2( LSTICC ) ) + VN1( LSTICC ) = DNRM2( M-RK, A( RK+1, LSTICC ), 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 + GO TO 40 + END IF +* + RETURN +* +* End of DLAQPS +* + END diff --git a/2.3-1/src/fortran/lapack/dlaqr0.f b/2.3-1/src/fortran/lapack/dlaqr0.f new file mode 100644 index 00000000..479da53d --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlaqr0.f @@ -0,0 +1,642 @@ + SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), + $ Z( LDZ, * ) +* .. +* +* 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 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 increasing 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. ==== +* + INTEGER NTINY + PARAMETER ( NTINY = 11 ) + INTEGER KEXNW, KEXSH + PARAMETER ( KEXNW = 5, KEXSH = 6 ) + DOUBLE PRECISION WILK1, WILK2 + PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, + $ NSR, NVE, NW, NWMAX, NWR + LOGICAL NWINC, SORTED + CHARACTER JBCMPZ*2 +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Local Arrays .. + DOUBLE PRECISION ZDUM( 1, 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR3, DLAQR4, DLAQR5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD +* .. +* .. Executable Statements .. + INFO = 0 +* +* ==== Quick return for N = 0: nothing to do. ==== +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* +* ==== Tiny matrices must use DLAHQR. ==== +* + IF( N.LE.NTINY ) THEN +* +* ==== Estimate optimal workspace. ==== +* + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, INFO ) + ELSE +* +* ==== Use small bulge multi-shift QR with aggressive early +* . deflation on larger-than-tiny matrices. ==== +* +* ==== Hope for the best. ==== +* + INFO = 0 +* +* ==== 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( 13, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) + NW = NWR +* +* ==== NSR = recommended number of simultaneous shifts. +* . At this point N .GT. NTINY = 11, so there is at +* . enough subdiagonal workspace for NSR to be even +* . and greater than or equal to two as required. ==== +* + NSR = ILAENV( 15, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) +* +* ==== Estimate optimal workspace ==== +* +* ==== Workspace query call to DLAQR3 ==== +* + CALL DLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH, + $ N, H, LDH, WORK, -1 ) +* +* ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ==== +* + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ==== DLAHQR/DLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== Nibble crossover point ==== +* + NIBBLE = ILAENV( 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( 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. ==== +* + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) +* +* ==== NSMAX = the Largest number of simultaneous shifts +* . for which there is sufficient workspace. ==== +* + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) +* +* ==== NDFL: an iteration count restarted at deflation. ==== +* + NDFL = 1 +* +* ==== ITMAX = iteration limit ==== +* + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) +* +* ==== Last row and column in the active block ==== +* + KBOT = IHI +* +* ==== Main Loop ==== +* + DO 80 IT = 1, ITMAX +* +* ==== Done when KBOT falls below ILO ==== +* + IF( KBOT.LT.ILO ) + $ GO TO 90 +* +* ==== Locate active block ==== +* + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K +* +* ==== Select deflation window size ==== +* + NH = KBOT - KTOP + 1 + IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN +* +* ==== Typical deflation window. If possible and +* . advisable, nibble the entire active block. +* . If not, use size NWR or NWR+1 depending upon +* . which has the smaller corresponding subdiagonal +* . entry (a heuristic). ==== +* + NWINC = .TRUE. + IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN + NW = NH + ELSE + NW = MIN( NWR, NH, NWMAX ) + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. + $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + END IF + ELSE +* +* ==== Exceptional deflation window. If there have +* . been no deflations in KEXNW or more iterations, +* . then vary the deflation window size. At first, +* . because, larger windows are, in general, more +* . powerful than smaller ones, rapidly increase the +* . window up to the maximum reasonable and possible. +* . Then maybe try a slightly smaller window. ==== +* + IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN + NW = MIN( NWMAX, NH, 2*NW ) + ELSE + NWINC = .FALSE. + IF( NW.EQ.NH .AND. NH.GT.2 ) + $ NW = NH - 1 + END IF + END IF +* +* ==== 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 ==== +* + CALL DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH, + $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, + $ WORK, LWORK ) +* +* ==== Adjust KBOT accounting for new deflations. ==== +* + KBOT = 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.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN +* +* ==== NS = nominal number of simultaneous shifts. +* . This may be lowered (slightly) if DLAQR3 +* . did not provide that many shifts. ==== +* + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( 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( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2 + SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) + AA = WILK1*SS + H( I, I ) + BB = SS + CC = WILK2*SS + DD = AA + CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ), + $ WR( I ), WI( I ), CS, SN ) + 30 CONTINUE + IF( KS.EQ.KTOP ) THEN + WR( KS+1 ) = H( KS+1, KS+1 ) + WI( KS+1 ) = ZERO + WR( KS ) = WR( KS+1 ) + WI( KS ) = WI( KS+1 ) + END IF + 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.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + IF( NS.GT.NMIN ) THEN + CALL DLAQR4( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, WR( KS ), + $ WI( KS ), 1, 1, ZDUM, 1, WORK, + $ LWORK, INF ) + ELSE + CALL DLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, WR( KS ), + $ WI( KS ), 1, 1, ZDUM, 1, INF ) + END IF + KS = KS + INF +* +* ==== In case of a rare QR failure use +* . eigenvalues of the trailing 2-by-2 +* . principal submatrix. ==== +* + IF( KS.GE.KBOT ) THEN + AA = H( KBOT-1, KBOT-1 ) + CC = H( KBOT, KBOT-1 ) + BB = H( KBOT-1, KBOT ) + DD = H( KBOT, KBOT ) + CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ), + $ WI( KBOT-1 ), WR( KBOT ), + $ WI( KBOT ), CS, SN ) + KS = KBOT - 1 + END IF + END IF +* + IF( KBOT-KS+1.GT.NS ) THEN +* +* ==== Sort the shifts (Helps a little) +* . Bubble sort keeps complex conjugate +* . pairs together. ==== +* + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( ABS( WR( I ) )+ABS( WI( I ) ).LT. + $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN + 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 + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF +* +* ==== 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.) ==== +* + DO 70 I = KBOT, KS + 2, -2 + IF( WI( I ).NE.-WI( I-1 ) ) THEN +* + 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 + END IF + 70 CONTINUE + END IF +* +* ==== If there are only two shifts and both are +* . real, then use only one. ==== +* + IF( KBOT-KS+1.EQ.2 ) THEN + IF( WI( KBOT ).EQ.ZERO ) THEN + IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT. + $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + WR( KBOT-1 ) = WR( KBOT ) + ELSE + WR( KBOT ) = WR( KBOT-1 ) + END IF + END IF + END IF +* +* ==== 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. ==== +* + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( 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 = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 +* +* ==== Small-bulge multi-shift QR sweep ==== +* + CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z, + $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE, + $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH ) + END IF +* +* ==== Note progress (or the lack of it). ==== +* + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF +* +* ==== End of main loop ==== + 80 CONTINUE +* +* ==== Iteration limit exceeded. Set INFO to show where +* . the problem occurred and exit. ==== +* + INFO = KBOT + 90 CONTINUE + END IF +* +* ==== Return the optimal value of LWORK. ==== +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* ==== End of DLAQR0 ==== +* + END diff --git a/2.3-1/src/fortran/lapack/dlaqr1.f b/2.3-1/src/fortran/lapack/dlaqr1.f new file mode 100644 index 00000000..c80fe668 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlaqr1.f @@ -0,0 +1,97 @@ + SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION SI1, SI2, SR1, SR2 + INTEGER LDH, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), V( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION H21S, H31S, S +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. + IF( N.EQ.2 ) THEN + S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) + IF( S.EQ.ZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-SR1 )* + $ ( ( H( 1, 1 )-SR2 ) / S ) - SI1*( SI2 / S ) + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) + END IF + ELSE + S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) + + $ ABS( H( 3, 1 ) ) + IF( S.EQ.ZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + V( 3 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + H31S = H( 3, 1 ) / S + V( 1 ) = ( H( 1, 1 )-SR1 )*( ( H( 1, 1 )-SR2 ) / S ) - + $ SI1*( SI2 / S ) + H( 1, 2 )*H21S + H( 1, 3 )*H31S + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) + + $ H( 2, 3 )*H31S + V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-SR1-SR2 ) + + $ H21S*H( 3, 2 ) + END IF + END IF + END diff --git a/2.3-1/src/fortran/lapack/dlaqr2.f b/2.3-1/src/fortran/lapack/dlaqr2.f new file mode 100644 index 00000000..6ddb3309 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlaqr2.f @@ -0,0 +1,551 @@ + SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, + $ LDT, NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), + $ V( LDV, * ), WORK( * ), WV( LDWV, * ), + $ Z( LDZ, * ) +* .. +* +* 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,IHI) +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, + $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, + $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, + $ LWKOPT + LOGICAL BULGE, SORTED +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, + $ DLANV2, DLARF, DLARFG, DLASET, DORGHR, DTREXC +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to DGEHRD ==== +* + CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to DORGHR ==== +* + CALL DORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = JW + MAX( LWK1, LWK2 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SR( KWTOP ) = H( KWTOP, KWTOP ) + SI( KWTOP ) = ZERO + NS = 1 + ND = 0 + IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) ) + $ THEN + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) +* + CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) +* +* ==== DTREXC needs a clean margin near the diagonal ==== +* + DO 10 J = 1, JW - 3 + T( J+2, J ) = ZERO + T( J+3, J ) = ZERO + 10 CONTINUE + IF( JW.GT.2 ) + $ T( JW, JW-2 ) = ZERO +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + 20 CONTINUE + IF( ILST.LE.NS ) THEN + IF( NS.EQ.1 ) THEN + BULGE = .FALSE. + ELSE + BULGE = T( NS, NS-1 ).NE.ZERO + END IF +* +* ==== Small spike tip test for deflation ==== +* + IF( .NOT.BULGE ) THEN +* +* ==== Real eigenvalue ==== +* + FOO = ABS( T( NS, NS ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 1 + ELSE +* +* ==== Undeflatable. Move it up out of the way. +* . (DTREXC can not fail in this case.) ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 1 + END IF + ELSE +* +* ==== Complex conjugate pair ==== +* + FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* + $ SQRT( ABS( T( NS-1, NS ) ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. + $ MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 2 + ELSE +* +* ==== Undflatable. Move them up out of the way. +* . Fortunately, DTREXC does the right thing with +* . ILST in case of a rare exchange failure. ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 2 + END IF + END IF +* +* ==== End deflation detection loop ==== +* + GO TO 20 + END IF +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting diagonal blocks of T improves accuracy for +* . graded matrices. Bubble sort deals well with +* . exchange failures. ==== +* + SORTED = .false. + I = NS + 1 + 30 CONTINUE + IF( SORTED ) + $ GO TO 50 + SORTED = .true. +* + KEND = I - 1 + I = INFQR + 1 + IF( I.EQ.NS ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + 40 CONTINUE + IF( K.LE.KEND ) THEN + IF( K.EQ.I+1 ) THEN + EVI = ABS( T( I, I ) ) + ELSE + EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* + $ SQRT( ABS( T( I, I+1 ) ) ) + END IF +* + IF( K.EQ.KEND ) THEN + EVK = ABS( T( K, K ) ) + ELSE IF( T( K+1, K ).EQ.ZERO ) THEN + EVK = ABS( T( K, K ) ) + ELSE + EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* + $ SQRT( ABS( T( K, K+1 ) ) ) + END IF +* + IF( EVI.GE.EVK ) THEN + I = K + ELSE + SORTED = .false. + IFST = I + ILST = K + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + IF( INFO.EQ.0 ) THEN + I = ILST + ELSE + I = K + END IF + END IF + IF( I.EQ.KEND ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + GO TO 40 + END IF + GO TO 30 + 50 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + I = JW + 60 CONTINUE + IF( I.GE.INFQR+1 ) THEN + IF( I.EQ.INFQR+1 ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE + AA = T( I-1, I-1 ) + CC = T( I, I-1 ) + BB = T( I-1, I ) + DD = T( I, I ) + CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), + $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), + $ SI( KWTOP+I-1 ), CS, SN ) + I = I - 2 + END IF + GO TO 60 + END IF +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL DCOPY( NS, V, LDV, WORK, 1 ) + BETA = WORK( 1 ) + CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE +* + CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) +* + CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) + CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. (A modified version +* . of DORGHR that accumulates block Householder +* . transformations into V directly might be +* . marginally more efficient than the following.) ==== +* + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN + CALL DORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + CALL DGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, + $ WV, LDWV ) + CALL DLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) + END IF +* +* ==== Update vertical slab in H ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 70 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 70 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 80 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 80 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 90 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 90 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* ==== End of DLAQR2 ==== +* + END diff --git a/2.3-1/src/fortran/lapack/dlaqr3.f b/2.3-1/src/fortran/lapack/dlaqr3.f new file mode 100644 index 00000000..877b267a --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlaqr3.f @@ -0,0 +1,561 @@ + SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, + $ LDT, NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), + $ V( LDV, * ), WORK( * ), WV( LDWV, * ), + $ Z( LDZ, * ) +* .. +* +* ****************************************************************** +* 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,IHI) +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, + $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, + $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, + $ LWKOPT, NMIN + LOGICAL BULGE, SORTED +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + EXTERNAL DLAMCH, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, + $ DLANV2, DLAQR4, DLARF, DLARFG, DLASET, DORGHR, + $ DTREXC +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to DGEHRD ==== +* + CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to DORGHR ==== +* + CALL DORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to DLAQR4 ==== +* + CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW, + $ V, LDV, WORK, -1, INFQR ) + LWK3 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SR( KWTOP ) = H( KWTOP, KWTOP ) + SI( KWTOP ) = ZERO + NS = 1 + ND = 0 + IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) ) + $ THEN + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) +* + CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + NMIN = ILAENV( 12, 'DLAQR3', 'SV', JW, 1, JW, LWORK ) + IF( JW.GT.NMIN ) THEN + CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR ) + ELSE + CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) + END IF +* +* ==== DTREXC needs a clean margin near the diagonal ==== +* + DO 10 J = 1, JW - 3 + T( J+2, J ) = ZERO + T( J+3, J ) = ZERO + 10 CONTINUE + IF( JW.GT.2 ) + $ T( JW, JW-2 ) = ZERO +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + 20 CONTINUE + IF( ILST.LE.NS ) THEN + IF( NS.EQ.1 ) THEN + BULGE = .FALSE. + ELSE + BULGE = T( NS, NS-1 ).NE.ZERO + END IF +* +* ==== Small spike tip test for deflation ==== +* + IF( .NOT.BULGE ) THEN +* +* ==== Real eigenvalue ==== +* + FOO = ABS( T( NS, NS ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 1 + ELSE +* +* ==== Undeflatable. Move it up out of the way. +* . (DTREXC can not fail in this case.) ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 1 + END IF + ELSE +* +* ==== Complex conjugate pair ==== +* + FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* + $ SQRT( ABS( T( NS-1, NS ) ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. + $ MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 2 + ELSE +* +* ==== Undflatable. Move them up out of the way. +* . Fortunately, DTREXC does the right thing with +* . ILST in case of a rare exchange failure. ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 2 + END IF + END IF +* +* ==== End deflation detection loop ==== +* + GO TO 20 + END IF +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting diagonal blocks of T improves accuracy for +* . graded matrices. Bubble sort deals well with +* . exchange failures. ==== +* + SORTED = .false. + I = NS + 1 + 30 CONTINUE + IF( SORTED ) + $ GO TO 50 + SORTED = .true. +* + KEND = I - 1 + I = INFQR + 1 + IF( I.EQ.NS ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + 40 CONTINUE + IF( K.LE.KEND ) THEN + IF( K.EQ.I+1 ) THEN + EVI = ABS( T( I, I ) ) + ELSE + EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* + $ SQRT( ABS( T( I, I+1 ) ) ) + END IF +* + IF( K.EQ.KEND ) THEN + EVK = ABS( T( K, K ) ) + ELSE IF( T( K+1, K ).EQ.ZERO ) THEN + EVK = ABS( T( K, K ) ) + ELSE + EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* + $ SQRT( ABS( T( K, K+1 ) ) ) + END IF +* + IF( EVI.GE.EVK ) THEN + I = K + ELSE + SORTED = .false. + IFST = I + ILST = K + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + IF( INFO.EQ.0 ) THEN + I = ILST + ELSE + I = K + END IF + END IF + IF( I.EQ.KEND ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + GO TO 40 + END IF + GO TO 30 + 50 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + I = JW + 60 CONTINUE + IF( I.GE.INFQR+1 ) THEN + IF( I.EQ.INFQR+1 ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE + AA = T( I-1, I-1 ) + CC = T( I, I-1 ) + BB = T( I-1, I ) + DD = T( I, I ) + CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), + $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), + $ SI( KWTOP+I-1 ), CS, SN ) + I = I - 2 + END IF + GO TO 60 + END IF +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL DCOPY( NS, V, LDV, WORK, 1 ) + BETA = WORK( 1 ) + CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE +* + CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) +* + CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) + CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. (A modified version +* . of DORGHR that accumulates block Householder +* . transformations into V directly might be +* . marginally more efficient than the following.) ==== +* + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN + CALL DORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + CALL DGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, + $ WV, LDWV ) + CALL DLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) + END IF +* +* ==== Update vertical slab in H ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 70 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 70 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 80 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 80 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 90 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 90 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* ==== End of DLAQR3 ==== +* + END diff --git a/2.3-1/src/fortran/lapack/dlaqr4.f b/2.3-1/src/fortran/lapack/dlaqr4.f new file mode 100644 index 00000000..8692e7f9 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlaqr4.f @@ -0,0 +1,640 @@ + SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), + $ Z( LDZ, * ) +* .. +* +* 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 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 increasing 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. ==== +* + INTEGER NTINY + PARAMETER ( NTINY = 11 ) + INTEGER KEXNW, KEXSH + PARAMETER ( KEXNW = 5, KEXSH = 6 ) + DOUBLE PRECISION WILK1, WILK2 + PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, + $ NSR, NVE, NW, NWMAX, NWR + LOGICAL NWINC, SORTED + CHARACTER JBCMPZ*2 +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Local Arrays .. + DOUBLE PRECISION ZDUM( 1, 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR2, DLAQR5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD +* .. +* .. Executable Statements .. + INFO = 0 +* +* ==== Quick return for N = 0: nothing to do. ==== +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* +* ==== Tiny matrices must use DLAHQR. ==== +* + IF( N.LE.NTINY ) THEN +* +* ==== Estimate optimal workspace. ==== +* + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, INFO ) + ELSE +* +* ==== Use small bulge multi-shift QR with aggressive early +* . deflation on larger-than-tiny matrices. ==== +* +* ==== Hope for the best. ==== +* + INFO = 0 +* +* ==== 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( 13, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) + NW = NWR +* +* ==== NSR = recommended number of simultaneous shifts. +* . At this point N .GT. NTINY = 11, so there is at +* . enough subdiagonal workspace for NSR to be even +* . and greater than or equal to two as required. ==== +* + NSR = ILAENV( 15, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) +* +* ==== Estimate optimal workspace ==== +* +* ==== Workspace query call to DLAQR2 ==== +* + CALL DLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH, + $ N, H, LDH, WORK, -1 ) +* +* ==== Optimal workspace = MAX(DLAQR5, DLAQR2) ==== +* + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ==== DLAHQR/DLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== Nibble crossover point ==== +* + NIBBLE = ILAENV( 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( 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. ==== +* + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) +* +* ==== NSMAX = the Largest number of simultaneous shifts +* . for which there is sufficient workspace. ==== +* + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) +* +* ==== NDFL: an iteration count restarted at deflation. ==== +* + NDFL = 1 +* +* ==== ITMAX = iteration limit ==== +* + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) +* +* ==== Last row and column in the active block ==== +* + KBOT = IHI +* +* ==== Main Loop ==== +* + DO 80 IT = 1, ITMAX +* +* ==== Done when KBOT falls below ILO ==== +* + IF( KBOT.LT.ILO ) + $ GO TO 90 +* +* ==== Locate active block ==== +* + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K +* +* ==== Select deflation window size ==== +* + NH = KBOT - KTOP + 1 + IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN +* +* ==== Typical deflation window. If possible and +* . advisable, nibble the entire active block. +* . If not, use size NWR or NWR+1 depending upon +* . which has the smaller corresponding subdiagonal +* . entry (a heuristic). ==== +* + NWINC = .TRUE. + IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN + NW = NH + ELSE + NW = MIN( NWR, NH, NWMAX ) + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. + $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + END IF + ELSE +* +* ==== Exceptional deflation window. If there have +* . been no deflations in KEXNW or more iterations, +* . then vary the deflation window size. At first, +* . because, larger windows are, in general, more +* . powerful than smaller ones, rapidly increase the +* . window up to the maximum reasonable and possible. +* . Then maybe try a slightly smaller window. ==== +* + IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN + NW = MIN( NWMAX, NH, 2*NW ) + ELSE + NWINC = .FALSE. + IF( NW.EQ.NH .AND. NH.GT.2 ) + $ NW = NH - 1 + END IF + END IF +* +* ==== 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 ==== +* + CALL DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH, + $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, + $ WORK, LWORK ) +* +* ==== Adjust KBOT accounting for new deflations. ==== +* + KBOT = 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.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN +* +* ==== NS = nominal number of simultaneous shifts. +* . This may be lowered (slightly) if DLAQR2 +* . did not provide that many shifts. ==== +* + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( 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( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2 + SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) + AA = WILK1*SS + H( I, I ) + BB = SS + CC = WILK2*SS + DD = AA + CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ), + $ WR( I ), WI( I ), CS, SN ) + 30 CONTINUE + IF( KS.EQ.KTOP ) THEN + WR( KS+1 ) = H( KS+1, KS+1 ) + WI( KS+1 ) = ZERO + WR( KS ) = WR( KS+1 ) + WI( KS ) = WI( KS+1 ) + END IF + 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.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + CALL DLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, WR( KS ), WI( KS ), + $ 1, 1, ZDUM, 1, INF ) + KS = KS + INF +* +* ==== In case of a rare QR failure use +* . eigenvalues of the trailing 2-by-2 +* . principal submatrix. ==== +* + IF( KS.GE.KBOT ) THEN + AA = H( KBOT-1, KBOT-1 ) + CC = H( KBOT, KBOT-1 ) + BB = H( KBOT-1, KBOT ) + DD = H( KBOT, KBOT ) + CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ), + $ WI( KBOT-1 ), WR( KBOT ), + $ WI( KBOT ), CS, SN ) + KS = KBOT - 1 + END IF + END IF +* + IF( KBOT-KS+1.GT.NS ) THEN +* +* ==== Sort the shifts (Helps a little) +* . Bubble sort keeps complex conjugate +* . pairs together. ==== +* + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( ABS( WR( I ) )+ABS( WI( I ) ).LT. + $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN + 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 + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF +* +* ==== 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.) ==== +* + DO 70 I = KBOT, KS + 2, -2 + IF( WI( I ).NE.-WI( I-1 ) ) THEN +* + 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 + END IF + 70 CONTINUE + END IF +* +* ==== If there are only two shifts and both are +* . real, then use only one. ==== +* + IF( KBOT-KS+1.EQ.2 ) THEN + IF( WI( KBOT ).EQ.ZERO ) THEN + IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT. + $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + WR( KBOT-1 ) = WR( KBOT ) + ELSE + WR( KBOT ) = WR( KBOT-1 ) + END IF + END IF + END IF +* +* ==== 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. ==== +* + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( 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 = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 +* +* ==== Small-bulge multi-shift QR sweep ==== +* + CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z, + $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE, + $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH ) + END IF +* +* ==== Note progress (or the lack of it). ==== +* + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF +* +* ==== End of main loop ==== + 80 CONTINUE +* +* ==== Iteration limit exceeded. Set INFO to show where +* . the problem occurred and exit. ==== +* + INFO = KBOT + 90 CONTINUE + END IF +* +* ==== Return the optimal value of LWORK. ==== +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* ==== End of DLAQR4 ==== +* + END diff --git a/2.3-1/src/fortran/lapack/dlaqr5.f b/2.3-1/src/fortran/lapack/dlaqr5.f new file mode 100644 index 00000000..17857572 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlaqr5.f @@ -0,0 +1,812 @@ + SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, + $ SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, + $ LDU, NV, WV, LDWV, NH, WH, LDWH ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, + $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), U( LDU, * ), + $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), + $ Z( LDZ, * ) +* .. +* +* 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) DOUBLE PRECISION array of size (NSHFTS) +* SI (input) 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. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION ALPHA, BETA, H11, H12, H21, H22, REFSUM, + $ SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2, + $ ULP + INTEGER I, I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, + $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, + $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, + $ NS, NU + LOGICAL ACCUM, BLK22, BMP22 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. +* + INTRINSIC ABS, DBLE, MAX, MIN, MOD +* .. +* .. Local Arrays .. + DOUBLE PRECISION VT( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLABAD, DLACPY, DLAQR1, DLARFG, DLASET, + $ DTRMM +* .. +* .. Executable Statements .. +* +* ==== If there are no shifts, then there is nothing to do. ==== +* + IF( NSHFTS.LT.2 ) + $ RETURN +* +* ==== If the active block is empty or 1-by-1, then there +* . is nothing to do. ==== +* + IF( KTOP.GE.KBOT ) + $ RETURN +* +* ==== Shuffle shifts into pairs of real shifts and pairs +* . of complex conjugate shifts assuming complex +* . conjugate shifts are already adjacent to one +* . another. ==== +* + DO 10 I = 1, NSHFTS - 2, 2 + IF( SI( I ).NE.-SI( I+1 ) ) THEN +* + 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 + END IF + 10 CONTINUE +* +* ==== NSHFTS is supposed to be even, but if 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 - MOD( NSHFTS, 2 ) +* +* ==== Machine constants for deflation ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Use accumulated reflections to update far-from-diagonal +* . entries ? ==== +* + ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) +* +* ==== If so, exploit the 2-by-2 block structure? ==== +* + BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) +* +* ==== clear trash ==== +* + IF( KTOP+2.LE.KBOT ) + $ H( KTOP+2, KTOP ) = ZERO +* +* ==== NBMPS = number of 2-shift bulges in the chain ==== +* + NBMPS = NS / 2 +* +* ==== KDU = width of slab ==== +* + KDU = 6*NBMPS - 3 +* +* ==== Create and chase chains of NBMPS bulges ==== +* + DO 220 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 + NDCOL = INCOL + KDU + IF( ACCUM ) + $ CALL DLASET( 'ALL', KDU, KDU, ZERO, ONE, U, 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.) ==== +* + DO 150 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) +* +* ==== 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. ==== +* + MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 ) + MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 ) + M22 = MBOT + 1 + BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ. + $ ( KBOT-2 ) +* +* ==== Generate reflections to chase the chain right +* . one column. (The minimum value of K is KTOP-1.) ==== +* + DO 20 M = MTOP, MBOT + K = KRCOL + 3*( M-1 ) + IF( K.EQ.KTOP-1 ) THEN + CALL DLAQR1( 3, H( KTOP, KTOP ), LDH, SR( 2*M-1 ), + $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), + $ V( 1, M ) ) + ALPHA = V( 1, M ) + CALL DLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) ) + ELSE + BETA = H( K+1, K ) + V( 2, M ) = H( K+2, K ) + V( 3, M ) = H( K+3, K ) + CALL DLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) +* +* ==== A Bulge may collapse because of vigilant +* . deflation or destructive underflow. (The +* . initial bulge is always collapsed.) Use +* . the two-small-subdiagonals trick to try +* . to get it started again. If V(2,M).NE.0 and +* . V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then +* . this bulge is collapsing into a zero +* . subdiagonal. It will be restarted next +* . trip through the loop.) +* + IF( V( 1, M ).NE.ZERO .AND. + $ ( V( 3, M ).NE.ZERO .OR. ( H( K+3, + $ K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) ) + $ THEN +* +* ==== Typical case: not collapsed (yet). ==== +* + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + ELSE +* +* ==== Atypical case: collapsed. Attempt to +* . reintroduce ignoring H(K+1,K). If the +* . fill resulting from the new reflector +* . is too large, then abandon it. +* . Otherwise, use the new one. ==== +* + CALL DLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ), + $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), + $ VT ) + SCL = ABS( VT( 1 ) ) + ABS( VT( 2 ) ) + + $ ABS( VT( 3 ) ) + IF( SCL.NE.ZERO ) THEN + VT( 1 ) = VT( 1 ) / SCL + VT( 2 ) = VT( 2 ) / SCL + VT( 3 ) = VT( 3 ) / SCL + END IF +* +* ==== The following is the traditional and +* . conservative two-small-subdiagonals +* . test. ==== +* . + IF( ABS( H( K+1, K ) )*( ABS( VT( 2 ) )+ + $ ABS( VT( 3 ) ) ).GT.ULP*ABS( VT( 1 ) )* + $ ( ABS( H( K, K ) )+ABS( H( K+1, + $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN +* +* ==== Starting a new bulge here would +* . create non-negligible fill. If +* . the old reflector is diagonal (only +* . possible with underflows), then +* . change it to I. Otherwise, use +* . it with trepidation. ==== +* + IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO ) + $ THEN + V( 1, M ) = ZERO + ELSE + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + END IF + ELSE +* +* ==== Stating a new bulge here would +* . create only negligible fill. +* . Replace the old reflector with +* . the new one. ==== +* + ALPHA = VT( 1 ) + CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) + REFSUM = H( K+1, K ) + H( K+2, K )*VT( 2 ) + + $ H( K+3, K )*VT( 3 ) + H( K+1, K ) = H( K+1, K ) - VT( 1 )*REFSUM + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + V( 1, M ) = VT( 1 ) + V( 2, M ) = VT( 2 ) + V( 3, M ) = VT( 3 ) + END IF + END IF + END IF + 20 CONTINUE +* +* ==== Generate a 2-by-2 reflection, if needed. ==== +* + K = KRCOL + 3*( M22-1 ) + IF( BMP22 ) THEN + IF( K.EQ.KTOP-1 ) THEN + CALL DLAQR1( 2, H( K+1, K+1 ), LDH, SR( 2*M22-1 ), + $ SI( 2*M22-1 ), SR( 2*M22 ), SI( 2*M22 ), + $ V( 1, M22 ) ) + BETA = V( 1, M22 ) + CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) + ELSE + BETA = H( K+1, K ) + V( 2, M22 ) = H( K+2, K ) + CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + END IF + ELSE +* +* ==== Initialize V(1,M22) here to avoid possible undefined +* . variable problems later. ==== +* + V( 1, M22 ) = ZERO + END IF +* +* ==== Multiply H by reflections from the left ==== +* + IF( ACCUM ) THEN + JBOT = MIN( NDCOL, KBOT ) + ELSE IF( WANTT ) THEN + JBOT = N + ELSE + JBOT = KBOT + END IF + DO 40 J = MAX( KTOP, KRCOL ), JBOT + MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) + DO 30 M = MTOP, MEND + K = KRCOL + 3*( M-1 ) + REFSUM = V( 1, M )*( H( K+1, J )+V( 2, M )* + $ H( K+2, J )+V( 3, M )*H( K+3, J ) ) + H( K+1, J ) = H( K+1, J ) - REFSUM + H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M ) + H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M ) + 30 CONTINUE + 40 CONTINUE + IF( BMP22 ) THEN + K = KRCOL + 3*( M22-1 ) + DO 50 J = MAX( K+1, KTOP ), JBOT + REFSUM = V( 1, M22 )*( H( K+1, J )+V( 2, M22 )* + $ H( K+2, J ) ) + H( K+1, J ) = H( K+1, J ) - REFSUM + H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 ) + 50 CONTINUE + END IF +* +* ==== Multiply H by reflections from the right. +* . Delay filling in the last row until the +* . vigilant deflation check is complete. ==== +* + IF( ACCUM ) THEN + JTOP = MAX( KTOP, INCOL ) + ELSE IF( WANTT ) THEN + JTOP = 1 + ELSE + JTOP = KTOP + END IF + DO 90 M = MTOP, MBOT + IF( V( 1, M ).NE.ZERO ) THEN + K = KRCOL + 3*( M-1 ) + DO 60 J = JTOP, MIN( KBOT, K+3 ) + REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* + $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) ) + H( J, K+1 ) = H( J, K+1 ) - REFSUM + H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M ) + H( J, K+3 ) = H( J, K+3 ) - REFSUM*V( 3, M ) + 60 CONTINUE +* + IF( ACCUM ) THEN +* +* ==== Accumulate U. (If necessary, update Z later +* . with with an efficient matrix-matrix +* . multiply.) ==== +* + KMS = K - INCOL + DO 70 J = MAX( 1, KTOP-INCOL ), KDU + REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* + $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) ) + U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM + U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M ) + U( J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*V( 3, M ) + 70 CONTINUE + ELSE IF( WANTZ ) THEN +* +* ==== U is not accumulated, so update Z +* . now by multiplying by reflections +* . from the right. ==== +* + DO 80 J = ILOZ, IHIZ + REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* + $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) ) + Z( J, K+1 ) = Z( J, K+1 ) - REFSUM + Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M ) + Z( J, K+3 ) = Z( J, K+3 ) - REFSUM*V( 3, M ) + 80 CONTINUE + END IF + END IF + 90 CONTINUE +* +* ==== Special case: 2-by-2 reflection (if needed) ==== +* + K = KRCOL + 3*( M22-1 ) + IF( BMP22 .AND. ( V( 1, M22 ).NE.ZERO ) ) THEN + DO 100 J = JTOP, MIN( KBOT, K+3 ) + REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* + $ H( J, K+2 ) ) + H( J, K+1 ) = H( J, K+1 ) - REFSUM + H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M22 ) + 100 CONTINUE +* + IF( ACCUM ) THEN + KMS = K - INCOL + DO 110 J = MAX( 1, KTOP-INCOL ), KDU + REFSUM = V( 1, M22 )*( U( J, KMS+1 )+V( 2, M22 )* + $ U( J, KMS+2 ) ) + U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM + U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M22 ) + 110 CONTINUE + ELSE IF( WANTZ ) THEN + DO 120 J = ILOZ, IHIZ + REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* + $ Z( J, K+2 ) ) + Z( J, K+1 ) = Z( J, K+1 ) - REFSUM + Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M22 ) + 120 CONTINUE + END IF + END IF +* +* ==== Vigilant deflation check ==== +* + MSTART = MTOP + IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) + $ MSTART = MSTART + 1 + MEND = MBOT + IF( BMP22 ) + $ MEND = MEND + 1 + IF( KRCOL.EQ.KBOT-2 ) + $ MEND = MEND + 1 + DO 130 M = MSTART, MEND + K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) +* +* ==== 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 ).NE.ZERO ) THEN + TST1 = ABS( H( K, K ) ) + ABS( H( K+1, K+1 ) ) + IF( TST1.EQ.ZERO ) THEN + IF( K.GE.KTOP+1 ) + $ TST1 = TST1 + ABS( H( K, K-1 ) ) + IF( K.GE.KTOP+2 ) + $ TST1 = TST1 + ABS( H( K, K-2 ) ) + IF( K.GE.KTOP+3 ) + $ TST1 = TST1 + ABS( H( K, K-3 ) ) + IF( K.LE.KBOT-2 ) + $ TST1 = TST1 + ABS( H( K+2, K+1 ) ) + IF( K.LE.KBOT-3 ) + $ TST1 = TST1 + ABS( H( K+3, K+1 ) ) + IF( K.LE.KBOT-4 ) + $ TST1 = TST1 + ABS( H( K+4, K+1 ) ) + END IF + IF( ABS( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) + $ THEN + H12 = MAX( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) ) + H21 = MIN( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) ) + H11 = MAX( ABS( H( K+1, K+1 ) ), + $ ABS( H( K, K )-H( K+1, K+1 ) ) ) + H22 = MIN( ABS( H( K+1, K+1 ) ), + $ ABS( H( K, K )-H( K+1, K+1 ) ) ) + SCL = H11 + H12 + TST2 = H22*( H11 / SCL ) +* + IF( TST2.EQ.ZERO .OR. H21*( H12 / SCL ).LE. + $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO + END IF + END IF + 130 CONTINUE +* +* ==== Fill in the last row of each bulge. ==== +* + MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) + DO 140 M = MTOP, MEND + K = KRCOL + 3*( M-1 ) + REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 ) + H( K+4, K+1 ) = -REFSUM + H( K+4, K+2 ) = -REFSUM*V( 2, M ) + H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*V( 3, M ) + 140 CONTINUE +* +* ==== End of near-the-diagonal bulge chase. ==== +* + 150 CONTINUE +* +* ==== Use U (if accumulated) to update far-from-diagonal +* . entries in H. If required, use U to update Z as +* . well. ==== +* + IF( ACCUM ) THEN + IF( WANTT ) THEN + JTOP = 1 + JBOT = N + ELSE + JTOP = KTOP + JBOT = KBOT + END IF + IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. + $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN +* +* ==== 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. ==== +* + K1 = MAX( 1, KTOP-INCOL ) + NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 +* +* ==== Horizontal Multiply ==== +* + DO 160 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) + CALL DGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), + $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, + $ LDWH ) + CALL DLACPY( 'ALL', NU, JLEN, WH, LDWH, + $ H( INCOL+K1, JCOL ), LDH ) + 160 CONTINUE +* +* ==== Vertical multiply ==== +* + DO 170 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV + JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) + CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE, + $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), + $ LDU, ZERO, WV, LDWV ) + CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV, + $ H( JROW, INCOL+K1 ), LDH ) + 170 CONTINUE +* +* ==== Z multiply (also vertical) ==== +* + IF( WANTZ ) THEN + DO 180 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) + CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE, + $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), + $ LDU, ZERO, WV, LDWV ) + CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV, + $ Z( JROW, INCOL+K1 ), LDZ ) + 180 CONTINUE + END IF + 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 ==== +* + DO 190 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) +* +* ==== Copy bottom of H to top+KZS of scratch ==== +* (The first KZS rows get multiplied by zero.) ==== +* + CALL DLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), + $ LDH, WH( KZS+1, 1 ), LDWH ) +* +* ==== Multiply by U21' ==== +* + CALL DLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) + CALL DTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, + $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), + $ LDWH ) +* +* ==== Multiply top of H by U11' ==== +* + CALL DGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, + $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) +* +* ==== Copy top of H bottom of WH ==== +* + CALL DLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, + $ WH( I2+1, 1 ), LDWH ) +* +* ==== Multiply by U21' ==== +* + CALL DTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, + $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) +* +* ==== Multiply by U22 ==== +* + CALL DGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, + $ U( J2+1, I2+1 ), LDU, + $ H( INCOL+1+J2, JCOL ), LDH, ONE, + $ WH( I2+1, 1 ), LDWH ) +* +* ==== Copy it back ==== +* + CALL DLACPY( 'ALL', KDU, JLEN, WH, LDWH, + $ H( INCOL+1, JCOL ), LDH ) + 190 CONTINUE +* +* ==== Vertical multiply ==== +* + DO 200 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV + JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) +* +* ==== Copy right of H to scratch (the first KZS +* . columns get multiplied by zero) ==== +* + CALL DLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), + $ LDH, WV( 1, 1+KZS ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) + CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, + $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), + $ LDWV ) +* +* ==== Multiply by U11 ==== +* + CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, + $ LDWV ) +* +* ==== Copy left of H to right of scratch ==== +* + CALL DLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, + $ WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U22 ==== +* + CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, + $ H( JROW, INCOL+1+J2 ), LDH, + $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ), + $ LDWV ) +* +* ==== Copy it back ==== +* + CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ H( JROW, INCOL+1 ), LDH ) + 200 CONTINUE +* +* ==== Multiply Z (also vertical) ==== +* + IF( WANTZ ) THEN + DO 210 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) +* +* ==== Copy right of Z to left of scratch (first +* . KZS columns get multiplied by zero) ==== +* + CALL DLACPY( 'ALL', JLEN, KNZ, + $ Z( JROW, INCOL+1+J2 ), LDZ, + $ WV( 1, 1+KZS ), LDWV ) +* +* ==== Multiply by U12 ==== +* + CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, + $ LDWV ) + CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, + $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), + $ LDWV ) +* +* ==== Multiply by U11 ==== +* + CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, + $ WV, LDWV ) +* +* ==== Copy left of Z to right of scratch ==== +* + CALL DLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), + $ LDZ, WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), + $ LDWV ) +* +* ==== Multiply by U22 ==== +* + CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, + $ Z( JROW, INCOL+1+J2 ), LDZ, + $ U( J2+1, I2+1 ), LDU, ONE, + $ WV( 1, 1+I2 ), LDWV ) +* +* ==== Copy the result back to Z ==== +* + CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ Z( JROW, INCOL+1 ), LDZ ) + 210 CONTINUE + END IF + END IF + END IF + 220 CONTINUE +* +* ==== End of DLAQR5 ==== +* + END diff --git a/2.3-1/src/fortran/lapack/dlarf.f b/2.3-1/src/fortran/lapack/dlarf.f new file mode 100644 index 00000000..22edc899 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlarf.f @@ -0,0 +1,115 @@ + SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C +* + IF( TAU.NE.ZERO ) THEN +* +* w := C' * v +* + CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO, + $ WORK, 1 ) +* +* C := C - v * w' +* + CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) + END IF + ELSE +* +* Form C * H +* + IF( TAU.NE.ZERO ) THEN +* +* w := C * v +* + CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, + $ ZERO, WORK, 1 ) +* +* C := C - w * v' +* + CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) + END IF + END IF + RETURN +* +* End of DLARF +* + END diff --git a/2.3-1/src/fortran/lapack/dlarfb.f b/2.3-1/src/fortran/lapack/dlarfb.f new file mode 100644 index 00000000..d4422473 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlarfb.f @@ -0,0 +1,587 @@ + SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, + $ T, LDT, C, LDC, WORK, LDWORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), + $ WORK( LDWORK, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + CHARACTER TRANST + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DTRMM +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* + IF( LSAME( TRANS, 'N' ) ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* + IF( LSAME( STOREV, 'C' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 ) (first K rows) +* ( V2 ) +* where V1 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C where C = ( C1 ) +* ( C2 ) +* +* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) +* +* W := C1' +* + DO 10 J = 1, K + CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 10 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C2'*V2 +* + CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T' or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W' +* + IF( M.GT.K ) THEN +* +* C2 := C2 - V2 * W' +* + CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1' +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W' +* + DO 30 J = 1, K + DO 20 I = 1, N + C( J, I ) = C( J, I ) - WORK( I, J ) + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C1 +* + DO 40 J = 1, K + CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) + 40 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C2 * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T' +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V' +* + IF( N.GT.K ) THEN +* +* C2 := C2 - W * V2' +* + CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1' +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 60 J = 1, K + DO 50 I = 1, M + C( I, J ) = C( I, J ) - WORK( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + ELSE +* +* Let V = ( V1 ) +* ( V2 ) (last K rows) +* where V2 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C where C = ( C1 ) +* ( C2 ) +* +* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) +* +* W := C2' +* + DO 70 J = 1, K + CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + 70 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C1'*V1 +* + CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T' or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W' +* + IF( M.GT.K ) THEN +* +* C1 := C1 - V1 * W' +* + CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) + END IF +* +* W := W * V2' +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W' +* + DO 90 J = 1, K + DO 80 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C2 +* + DO 100 J = 1, K + CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 100 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C1 * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T' +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V' +* + IF( N.GT.K ) THEN +* +* C1 := C1 - W * V1' +* + CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) + END IF +* +* W := W * V2' +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W +* + DO 120 J = 1, K + DO 110 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) + 110 CONTINUE + 120 CONTINUE + END IF + END IF +* + ELSE IF( LSAME( STOREV, 'R' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 V2 ) (V1: first K columns) +* where V1 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C where C = ( C1 ) +* ( C2 ) +* +* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) +* +* W := C1' +* + DO 130 J = 1, K + CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 130 CONTINUE +* +* W := W * V1' +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C2'*V2' +* + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, + $ WORK, LDWORK ) + END IF +* +* W := W * T' or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V' * W' +* + IF( M.GT.K ) THEN +* +* C2 := C2 - V2' * W' +* + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, + $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W' +* + DO 150 J = 1, K + DO 140 I = 1, N + C( J, I ) = C( J, I ) - WORK( I, J ) + 140 CONTINUE + 150 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) +* +* W := C1 +* + DO 160 J = 1, K + CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) + 160 CONTINUE +* +* W := W * V1' +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C2 * V2' +* + CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T' +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( N.GT.K ) THEN +* +* C2 := C2 - W * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 180 J = 1, K + DO 170 I = 1, M + C( I, J ) = C( I, J ) - WORK( I, J ) + 170 CONTINUE + 180 CONTINUE +* + END IF +* + ELSE +* +* Let V = ( V1 V2 ) (V2: last K columns) +* where V2 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C where C = ( C1 ) +* ( C2 ) +* +* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) +* +* W := C2' +* + DO 190 J = 1, K + CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + 190 CONTINUE +* +* W := W * V2' +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C1'*V1' +* + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T' or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V' * W' +* + IF( M.GT.K ) THEN +* +* C1 := C1 - V1' * W' +* + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, + $ V, LDV, WORK, LDWORK, ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W' +* + DO 210 J = 1, K + DO 200 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) + 200 CONTINUE + 210 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) +* +* W := C2 +* + DO 220 J = 1, K + CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 220 CONTINUE +* +* W := W * V2' +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C1 * V1' +* + CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T' +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( N.GT.K ) THEN +* +* C1 := C1 - W * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 240 J = 1, K + DO 230 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) + 230 CONTINUE + 240 CONTINUE +* + END IF +* + END IF + END IF +* + RETURN +* +* End of DLARFB +* + END diff --git a/2.3-1/src/fortran/lapack/dlarfg.f b/2.3-1/src/fortran/lapack/dlarfg.f new file mode 100644 index 00000000..be981880 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlarfg.f @@ -0,0 +1,137 @@ + SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION ALPHA, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER J, KNT + DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 + EXTERNAL DLAMCH, DLAPY2, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN +* .. +* .. External Subroutines .. + EXTERNAL DSCAL +* .. +* .. Executable Statements .. +* + IF( N.LE.1 ) THEN + TAU = ZERO + RETURN + END IF +* + XNORM = DNRM2( N-1, X, INCX ) +* + IF( XNORM.EQ.ZERO ) THEN +* +* H = I +* + TAU = ZERO + ELSE +* +* general case +* + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) + IF( ABS( BETA ).LT.SAFMIN ) THEN +* +* XNORM, BETA may be inaccurate; scale X and recompute them +* + RSAFMN = ONE / SAFMIN + KNT = 0 + 10 CONTINUE + KNT = KNT + 1 + CALL DSCAL( N-1, RSAFMN, X, INCX ) + BETA = BETA*RSAFMN + ALPHA = ALPHA*RSAFMN + IF( ABS( BETA ).LT.SAFMIN ) + $ GO TO 10 +* +* New BETA is at most 1, at least SAFMIN +* + XNORM = DNRM2( N-1, X, INCX ) + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + TAU = ( BETA-ALPHA ) / BETA + CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) +* +* If ALPHA is subnormal, it may lose relative accuracy +* + ALPHA = BETA + DO 20 J = 1, KNT + ALPHA = ALPHA*SAFMIN + 20 CONTINUE + ELSE + TAU = ( BETA-ALPHA ) / BETA + CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) + ALPHA = BETA + END IF + END IF +* + RETURN +* +* End of DLARFG +* + END diff --git a/2.3-1/src/fortran/lapack/dlarft.f b/2.3-1/src/fortran/lapack/dlarft.f new file mode 100644 index 00000000..2cd115f4 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlarft.f @@ -0,0 +1,217 @@ + SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION VII +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DTRMV +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 20 I = 1, K + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 10 J = 1, I + T( J, I ) = ZERO + 10 CONTINUE + ELSE +* +* general case +* + VII = V( I, I ) + V( I, I ) = ONE + IF( LSAME( STOREV, 'C' ) ) THEN +* +* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) +* + CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ), + $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, + $ T( 1, I ), 1 ) + ELSE +* +* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' +* + CALL DGEMV( 'No transpose', I-1, N-I+1, -TAU( I ), + $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, + $ T( 1, I ), 1 ) + END IF + V( I, I ) = VII +* +* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) +* + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, + $ LDT, T( 1, I ), 1 ) + T( I, I ) = TAU( I ) + END IF + 20 CONTINUE + ELSE + DO 40 I = K, 1, -1 + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 30 J = I, K + T( J, I ) = ZERO + 30 CONTINUE + ELSE +* +* general case +* + IF( I.LT.K ) THEN + IF( LSAME( STOREV, 'C' ) ) THEN + VII = V( N-K+I, I ) + V( N-K+I, I ) = ONE +* +* T(i+1:k,i) := +* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) +* + CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ), + $ V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO, + $ T( I+1, I ), 1 ) + V( N-K+I, I ) = VII + ELSE + VII = V( I, N-K+I ) + V( I, N-K+I ) = ONE +* +* T(i+1:k,i) := +* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' +* + CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ), + $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, + $ T( I+1, I ), 1 ) + V( I, N-K+I ) = VII + END IF +* +* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) +* + CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, + $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + END IF + T( I, I ) = TAU( I ) + END IF + 40 CONTINUE + END IF + RETURN +* +* End of DLARFT +* + END diff --git a/2.3-1/src/fortran/lapack/dlarfx.f b/2.3-1/src/fortran/lapack/dlarfx.f new file mode 100644 index 00000000..cc4654e0 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlarfx.f @@ -0,0 +1,638 @@ + SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER J + DOUBLE PRECISION SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, + $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER +* .. +* .. Executable Statements .. +* + IF( TAU.EQ.ZERO ) + $ RETURN + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C, where H has order m. +* + GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, + $ 170, 190 )M +* +* Code for general M +* +* w := C'*v +* + CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, 1, ZERO, WORK, + $ 1 ) +* +* C := C - tau * v * w' +* + CALL DGER( M, N, -TAU, V, 1, WORK, 1, C, LDC ) + GO TO 410 + 10 CONTINUE +* +* Special code for 1 x 1 Householder +* + T1 = ONE - TAU*V( 1 )*V( 1 ) + DO 20 J = 1, N + C( 1, J ) = T1*C( 1, J ) + 20 CONTINUE + GO TO 410 + 30 CONTINUE +* +* Special code for 2 x 2 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + DO 40 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + 40 CONTINUE + GO TO 410 + 50 CONTINUE +* +* 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 + DO 60 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + 60 CONTINUE + GO TO 410 + 70 CONTINUE +* +* 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 + DO 80 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + 80 CONTINUE + GO TO 410 + 90 CONTINUE +* +* 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 + DO 100 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + 100 CONTINUE + GO TO 410 + 110 CONTINUE +* +* 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 + DO 120 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + C( 6, J ) = C( 6, J ) - SUM*T6 + 120 CONTINUE + GO TO 410 + 130 CONTINUE +* +* 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 + DO 140 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + + $ V7*C( 7, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + C( 6, J ) = C( 6, J ) - SUM*T6 + C( 7, J ) = C( 7, J ) - SUM*T7 + 140 CONTINUE + GO TO 410 + 150 CONTINUE +* +* 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 + DO 160 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + + $ V7*C( 7, J ) + V8*C( 8, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + C( 6, J ) = C( 6, J ) - SUM*T6 + C( 7, J ) = C( 7, J ) - SUM*T7 + C( 8, J ) = C( 8, J ) - SUM*T8 + 160 CONTINUE + GO TO 410 + 170 CONTINUE +* +* 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 + DO 180 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + C( 6, J ) = C( 6, J ) - SUM*T6 + C( 7, J ) = C( 7, J ) - SUM*T7 + C( 8, J ) = C( 8, J ) - SUM*T8 + C( 9, J ) = C( 9, J ) - SUM*T9 + 180 CONTINUE + GO TO 410 + 190 CONTINUE +* +* 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 + DO 200 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + + $ V10*C( 10, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + C( 6, J ) = C( 6, J ) - SUM*T6 + C( 7, J ) = C( 7, J ) - SUM*T7 + C( 8, J ) = C( 8, J ) - SUM*T8 + C( 9, J ) = C( 9, J ) - SUM*T9 + C( 10, J ) = C( 10, J ) - SUM*T10 + 200 CONTINUE + GO TO 410 + ELSE +* +* Form C * H, where H has order n. +* + GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, + $ 370, 390 )N +* +* Code for general N +* +* w := C * v +* + CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO, + $ WORK, 1 ) +* +* C := C - tau * w * v' +* + CALL DGER( M, N, -TAU, WORK, 1, V, 1, C, LDC ) + GO TO 410 + 210 CONTINUE +* +* Special code for 1 x 1 Householder +* + T1 = ONE - TAU*V( 1 )*V( 1 ) + DO 220 J = 1, M + C( J, 1 ) = T1*C( J, 1 ) + 220 CONTINUE + GO TO 410 + 230 CONTINUE +* +* Special code for 2 x 2 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + DO 240 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + 240 CONTINUE + GO TO 410 + 250 CONTINUE +* +* 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 + DO 260 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + 260 CONTINUE + GO TO 410 + 270 CONTINUE +* +* 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 + DO 280 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + 280 CONTINUE + GO TO 410 + 290 CONTINUE +* +* 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 + DO 300 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + 300 CONTINUE + GO TO 410 + 310 CONTINUE +* +* 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 + DO 320 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + C( J, 6 ) = C( J, 6 ) - SUM*T6 + 320 CONTINUE + GO TO 410 + 330 CONTINUE +* +* 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 + DO 340 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + + $ V7*C( J, 7 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + C( J, 6 ) = C( J, 6 ) - SUM*T6 + C( J, 7 ) = C( J, 7 ) - SUM*T7 + 340 CONTINUE + GO TO 410 + 350 CONTINUE +* +* 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 + DO 360 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + + $ V7*C( J, 7 ) + V8*C( J, 8 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + C( J, 6 ) = C( J, 6 ) - SUM*T6 + C( J, 7 ) = C( J, 7 ) - SUM*T7 + C( J, 8 ) = C( J, 8 ) - SUM*T8 + 360 CONTINUE + GO TO 410 + 370 CONTINUE +* +* 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 + DO 380 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + C( J, 6 ) = C( J, 6 ) - SUM*T6 + C( J, 7 ) = C( J, 7 ) - SUM*T7 + C( J, 8 ) = C( J, 8 ) - SUM*T8 + C( J, 9 ) = C( J, 9 ) - SUM*T9 + 380 CONTINUE + GO TO 410 + 390 CONTINUE +* +* 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 + DO 400 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + + $ V10*C( J, 10 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + C( J, 6 ) = C( J, 6 ) - SUM*T6 + C( J, 7 ) = C( J, 7 ) - SUM*T7 + C( J, 8 ) = C( J, 8 ) - SUM*T8 + C( J, 9 ) = C( J, 9 ) - SUM*T9 + C( J, 10 ) = C( J, 10 ) - SUM*T10 + 400 CONTINUE + GO TO 410 + END IF + 410 CONTINUE + RETURN +* +* End of DLARFX +* + END diff --git a/2.3-1/src/fortran/lapack/dlartg.f b/2.3-1/src/fortran/lapack/dlartg.f new file mode 100644 index 00000000..eb807c1d --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlartg.f @@ -0,0 +1,145 @@ + SUBROUTINE DLARTG( F, G, CS, SN, R ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION CS, F, G, R, SN +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) +* .. +* .. Local Scalars .. +* LOGICAL FIRST + INTEGER COUNT, I + DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, INT, LOG, MAX, SQRT +* .. +* .. Save statement .. +* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 +* .. +* .. Data statements .. +* DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* +* IF( FIRST ) THEN + SAFMIN = DLAMCH( 'S' ) + EPS = DLAMCH( 'E' ) + SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / + $ LOG( DLAMCH( 'B' ) ) / TWO ) + SAFMX2 = ONE / SAFMN2 +* FIRST = .FALSE. +* END IF + IF( G.EQ.ZERO ) THEN + CS = ONE + SN = ZERO + R = F + ELSE IF( F.EQ.ZERO ) THEN + CS = ZERO + SN = ONE + R = G + ELSE + F1 = F + G1 = G + SCALE = MAX( ABS( F1 ), ABS( G1 ) ) + IF( SCALE.GE.SAFMX2 ) THEN + COUNT = 0 + 10 CONTINUE + COUNT = COUNT + 1 + F1 = F1*SAFMN2 + G1 = G1*SAFMN2 + SCALE = MAX( ABS( F1 ), ABS( G1 ) ) + IF( SCALE.GE.SAFMX2 ) + $ GO TO 10 + R = SQRT( F1**2+G1**2 ) + CS = F1 / R + SN = G1 / R + DO 20 I = 1, COUNT + R = R*SAFMX2 + 20 CONTINUE + ELSE IF( SCALE.LE.SAFMN2 ) THEN + COUNT = 0 + 30 CONTINUE + COUNT = COUNT + 1 + F1 = F1*SAFMX2 + G1 = G1*SAFMX2 + SCALE = MAX( ABS( F1 ), ABS( G1 ) ) + IF( SCALE.LE.SAFMN2 ) + $ GO TO 30 + R = SQRT( F1**2+G1**2 ) + CS = F1 / R + SN = G1 / R + DO 40 I = 1, COUNT + R = R*SAFMN2 + 40 CONTINUE + ELSE + R = SQRT( F1**2+G1**2 ) + CS = F1 / R + SN = G1 / R + END IF + IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN + CS = -CS + SN = -SN + R = -R + END IF + END IF + RETURN +* +* End of DLARTG +* + END diff --git a/2.3-1/src/fortran/lapack/dlarz.f b/2.3-1/src/fortran/lapack/dlarz.f new file mode 100644 index 00000000..b302fdc2 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlarz.f @@ -0,0 +1,152 @@ + SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, L, LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C +* + IF( TAU.NE.ZERO ) THEN +* +* w( 1:n ) = C( 1, 1:n ) +* + CALL DCOPY( N, C, LDC, WORK, 1 ) +* +* w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) +* + CALL DGEMV( 'Transpose', L, N, ONE, C( M-L+1, 1 ), LDC, V, + $ INCV, ONE, WORK, 1 ) +* +* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) +* + CALL DAXPY( N, -TAU, WORK, 1, C, LDC ) +* +* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... +* tau * v( 1:l ) * w( 1:n )' +* + CALL DGER( L, N, -TAU, V, INCV, WORK, 1, C( M-L+1, 1 ), + $ LDC ) + END IF +* + ELSE +* +* Form C * H +* + IF( TAU.NE.ZERO ) THEN +* +* w( 1:m ) = C( 1:m, 1 ) +* + CALL DCOPY( M, C, 1, WORK, 1 ) +* +* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) +* + CALL DGEMV( 'No transpose', M, L, ONE, C( 1, N-L+1 ), LDC, + $ V, INCV, ONE, WORK, 1 ) +* +* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) +* + CALL DAXPY( M, -TAU, WORK, 1, C, 1 ) +* +* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... +* tau * w( 1:m ) * v( 1:l )' +* + CALL DGER( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ), + $ LDC ) +* + END IF +* + END IF +* + RETURN +* +* End of DLARZ +* + END diff --git a/2.3-1/src/fortran/lapack/dlarzb.f b/2.3-1/src/fortran/lapack/dlarzb.f new file mode 100644 index 00000000..ec59d8d5 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlarzb.f @@ -0,0 +1,220 @@ + SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, + $ LDV, T, LDT, C, LDC, WORK, LDWORK ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), + $ WORK( LDWORK, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + CHARACTER TRANST + INTEGER I, INFO, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DTRMM, XERBLA +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* +* Check for currently supported options +* + INFO = 0 + IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN + INFO = -3 + ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLARZB', -INFO ) + RETURN + END IF +* + IF( LSAME( TRANS, 'N' ) ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C +* +* W( 1:n, 1:k ) = C( 1:k, 1:n )' +* + DO 10 J = 1, K + CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 10 CONTINUE +* +* W( 1:n, 1:k ) = W( 1:n, 1:k ) + ... +* C( m-l+1:m, 1:n )' * V( 1:k, 1:l )' +* + IF( L.GT.0 ) + $ CALL DGEMM( 'Transpose', 'Transpose', N, K, L, ONE, + $ C( M-L+1, 1 ), LDC, V, LDV, ONE, WORK, LDWORK ) +* +* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, ONE, T, + $ LDT, WORK, LDWORK ) +* +* C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )' +* + DO 30 J = 1, N + DO 20 I = 1, K + C( I, J ) = C( I, J ) - WORK( J, I ) + 20 CONTINUE + 30 CONTINUE +* +* 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.GT.0 ) + $ CALL DGEMM( 'Transpose', 'Transpose', L, N, K, -ONE, V, LDV, + $ WORK, LDWORK, ONE, C( M-L+1, 1 ), LDC ) +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' +* +* W( 1:m, 1:k ) = C( 1:m, 1:k ) +* + DO 40 J = 1, K + CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) + 40 CONTINUE +* +* W( 1:m, 1:k ) = W( 1:m, 1:k ) + ... +* C( 1:m, n-l+1:n ) * V( 1:k, 1:l )' +* + IF( L.GT.0 ) + $ CALL DGEMM( 'No transpose', 'Transpose', M, K, L, ONE, + $ C( 1, N-L+1 ), LDC, V, LDV, ONE, WORK, LDWORK ) +* +* W( 1:m, 1:k ) = W( 1:m, 1:k ) * T or W( 1:m, 1:k ) * T' +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, ONE, T, + $ LDT, WORK, LDWORK ) +* +* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k ) +* + DO 60 J = 1, K + DO 50 I = 1, M + C( I, J ) = C( I, J ) - WORK( I, J ) + 50 CONTINUE + 60 CONTINUE +* +* 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.GT.0 ) + $ CALL DGEMM( 'No transpose', 'No transpose', M, L, K, -ONE, + $ WORK, LDWORK, V, LDV, ONE, C( 1, N-L+1 ), LDC ) +* + END IF +* + RETURN +* +* End of DLARZB +* + END diff --git a/2.3-1/src/fortran/lapack/dlarzt.f b/2.3-1/src/fortran/lapack/dlarzt.f new file mode 100644 index 00000000..d79636e0 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlarzt.f @@ -0,0 +1,184 @@ + SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DTRMV, XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Check for currently supported options +* + INFO = 0 + IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLARZT', -INFO ) + RETURN + END IF +* + DO 20 I = K, 1, -1 + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 10 J = I, K + T( J, I ) = ZERO + 10 CONTINUE + ELSE +* +* general case +* + IF( I.LT.K ) THEN +* +* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)' +* + CALL DGEMV( 'No transpose', K-I, N, -TAU( I ), + $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, + $ T( I+1, I ), 1 ) +* +* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i) +* + CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, + $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + END IF + T( I, I ) = TAU( I ) + END IF + 20 CONTINUE + RETURN +* +* End of DLARZT +* + END diff --git a/2.3-1/src/fortran/lapack/dlas2.f b/2.3-1/src/fortran/lapack/dlas2.f new file mode 100644 index 00000000..e100a4d8 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlas2.f @@ -0,0 +1,121 @@ + SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION F, G, H, SSMAX, SSMIN +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AS, AT, AU, C, FA, FHMN, FHMX, GA, HA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + FA = ABS( F ) + GA = ABS( G ) + HA = ABS( H ) + FHMN = MIN( FA, HA ) + FHMX = MAX( FA, HA ) + IF( FHMN.EQ.ZERO ) THEN + SSMIN = ZERO + IF( FHMX.EQ.ZERO ) THEN + SSMAX = GA + ELSE + SSMAX = MAX( FHMX, GA )*SQRT( ONE+ + $ ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 ) + END IF + ELSE + IF( GA.LT.FHMX ) THEN + AS = ONE + FHMN / FHMX + AT = ( FHMX-FHMN ) / FHMX + AU = ( GA / FHMX )**2 + C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) ) + SSMIN = FHMN*C + SSMAX = FHMX / C + ELSE + AU = FHMX / GA + IF( AU.EQ.ZERO ) THEN +* +* 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 = ONE + FHMN / FHMX + AT = ( FHMX-FHMN ) / FHMX + C = ONE / ( SQRT( ONE+( AS*AU )**2 )+ + $ SQRT( ONE+( AT*AU )**2 ) ) + SSMIN = ( FHMN*C )*AU + SSMIN = SSMIN + SSMIN + SSMAX = GA / ( C+C ) + END IF + END IF + END IF + RETURN +* +* End of DLAS2 +* + END diff --git a/2.3-1/src/fortran/lapack/dlascl.f b/2.3-1/src/fortran/lapack/dlascl.f new file mode 100644 index 00000000..7a7a78fd --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlascl.f @@ -0,0 +1,267 @@ + SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, KL, KU, LDA, M, N + DOUBLE PRECISION CFROM, CTO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER I, ITYPE, J, K1, K2, K3, K4 + DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 +* + IF( LSAME( TYPE, 'G' ) ) THEN + ITYPE = 0 + ELSE IF( LSAME( TYPE, 'L' ) ) THEN + ITYPE = 1 + ELSE IF( LSAME( TYPE, 'U' ) ) THEN + ITYPE = 2 + ELSE IF( LSAME( TYPE, 'H' ) ) THEN + ITYPE = 3 + ELSE IF( LSAME( TYPE, 'B' ) ) THEN + ITYPE = 4 + ELSE IF( LSAME( TYPE, 'Q' ) ) THEN + ITYPE = 5 + ELSE IF( LSAME( TYPE, 'Z' ) ) THEN + ITYPE = 6 + ELSE + ITYPE = -1 + END IF +* + IF( ITYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( CFROM.EQ.ZERO ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. + $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN + INFO = -7 + ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( ITYPE.GE.4 ) THEN + IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN + INFO = -2 + ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. + $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) + $ THEN + INFO = -3 + ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. + $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. + $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN + INFO = -9 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASCL', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +* +* Get machine parameters +* + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM +* + CFROMC = CFROM + CTOC = CTO +* + 10 CONTINUE + CFROM1 = CFROMC*SMLNUM + CTO1 = CTOC / BIGNUM + IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN + MUL = SMLNUM + DONE = .FALSE. + CFROMC = CFROM1 + ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN + MUL = BIGNUM + DONE = .FALSE. + CTOC = CTO1 + ELSE + MUL = CTOC / CFROMC + DONE = .TRUE. + END IF +* + IF( ITYPE.EQ.0 ) THEN +* +* Full matrix +* + DO 30 J = 1, N + DO 20 I = 1, M + A( I, J ) = A( I, J )*MUL + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( ITYPE.EQ.1 ) THEN +* +* Lower triangular matrix +* + DO 50 J = 1, N + DO 40 I = J, M + A( I, J ) = A( I, J )*MUL + 40 CONTINUE + 50 CONTINUE +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Upper triangular matrix +* + DO 70 J = 1, N + DO 60 I = 1, MIN( J, M ) + A( I, J ) = A( I, J )*MUL + 60 CONTINUE + 70 CONTINUE +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* Upper Hessenberg matrix +* + DO 90 J = 1, N + DO 80 I = 1, MIN( J+1, M ) + A( I, J ) = A( I, J )*MUL + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Lower half of a symmetric band matrix +* + K3 = KL + 1 + K4 = N + 1 + DO 110 J = 1, N + DO 100 I = 1, MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 100 CONTINUE + 110 CONTINUE +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Upper half of a symmetric band matrix +* + K1 = KU + 2 + K3 = KU + 1 + DO 130 J = 1, N + DO 120 I = MAX( K1-J, 1 ), K3 + A( I, J ) = A( I, J )*MUL + 120 CONTINUE + 130 CONTINUE +* + ELSE IF( ITYPE.EQ.6 ) THEN +* +* Band matrix +* + K1 = KL + KU + 2 + K2 = KL + 1 + K3 = 2*KL + KU + 1 + K4 = KL + KU + 1 + M + DO 150 J = 1, N + DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 140 CONTINUE + 150 CONTINUE +* + END IF +* + IF( .NOT.DONE ) + $ GO TO 10 +* + RETURN +* +* End of DLASCL +* + END diff --git a/2.3-1/src/fortran/lapack/dlaset.f b/2.3-1/src/fortran/lapack/dlaset.f new file mode 100644 index 00000000..fc7bc2f5 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlaset.f @@ -0,0 +1,114 @@ + SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, M, N + DOUBLE PRECISION ALPHA, BETA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* 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 .. + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Set the strictly upper triangular or trapezoidal part of the +* array to ALPHA. +* + DO 20 J = 2, N + DO 10 I = 1, MIN( J-1, M ) + A( I, J ) = ALPHA + 10 CONTINUE + 20 CONTINUE +* + ELSE IF( LSAME( UPLO, 'L' ) ) THEN +* +* Set the strictly lower triangular or trapezoidal part of the +* array to ALPHA. +* + DO 40 J = 1, MIN( M, N ) + DO 30 I = J + 1, M + A( I, J ) = ALPHA + 30 CONTINUE + 40 CONTINUE +* + ELSE +* +* Set the leading m-by-n submatrix to ALPHA. +* + DO 60 J = 1, N + DO 50 I = 1, M + A( I, J ) = ALPHA + 50 CONTINUE + 60 CONTINUE + END IF +* +* Set the first min(M,N) diagonal elements to BETA. +* + DO 70 I = 1, MIN( M, N ) + A( I, I ) = BETA + 70 CONTINUE +* + RETURN +* +* End of DLASET +* + END diff --git a/2.3-1/src/fortran/lapack/dlasq1.f b/2.3-1/src/fortran/lapack/dlasq1.f new file mode 100644 index 00000000..6f4c3413 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlasq1.f @@ -0,0 +1,148 @@ + SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I, IINFO + DOUBLE PRECISION EPS, SCALE, SAFMIN, SIGMN, SIGMX +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + CALL XERBLA( 'DLASQ1', -INFO ) + RETURN + ELSE IF( N.EQ.0 ) THEN + RETURN + ELSE IF( N.EQ.1 ) THEN + D( 1 ) = ABS( D( 1 ) ) + RETURN + ELSE IF( N.EQ.2 ) THEN + CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX ) + D( 1 ) = SIGMX + D( 2 ) = SIGMN + RETURN + END IF +* +* Estimate the largest singular value. +* + SIGMX = ZERO + DO 10 I = 1, N - 1 + D( I ) = ABS( D( I ) ) + SIGMX = MAX( SIGMX, ABS( E( I ) ) ) + 10 CONTINUE + D( N ) = ABS( D( N ) ) +* +* Early return if SIGMX is zero (matrix is already diagonal). +* + IF( SIGMX.EQ.ZERO ) THEN + CALL DLASRT( 'D', N, D, IINFO ) + RETURN + END IF +* + DO 20 I = 1, N + SIGMX = MAX( SIGMX, D( I ) ) + 20 CONTINUE +* +* 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 ) + CALL DCOPY( N, D, 1, WORK( 1 ), 2 ) + CALL DCOPY( N-1, E, 1, WORK( 2 ), 2 ) + CALL DLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1, + $ IINFO ) +* +* Compute the q's and e's. +* + DO 30 I = 1, 2*N - 1 + WORK( I ) = WORK( I )**2 + 30 CONTINUE + WORK( 2*N ) = ZERO +* + CALL DLASQ2( N, WORK, INFO ) +* + IF( INFO.EQ.0 ) THEN + DO 40 I = 1, N + D( I ) = SQRT( WORK( I ) ) + 40 CONTINUE + CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO ) + END IF +* + RETURN +* +* End of DLASQ1 +* + END diff --git a/2.3-1/src/fortran/lapack/dlasq2.f b/2.3-1/src/fortran/lapack/dlasq2.f new file mode 100644 index 00000000..b6b79aeb --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlasq2.f @@ -0,0 +1,448 @@ + SUBROUTINE DLASQ2( N, Z, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* Modified to call DLAZQ3 in place of DLASQ3, 13 Feb 03, SJH. +* +* .. Scalar Arguments .. + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* 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 DLAZQ3. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The number of rows and columns in the matrix. N >= 0. +* +* Z (workspace) 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 .. + DOUBLE PRECISION CBIAS + PARAMETER ( CBIAS = 1.50D0 ) + DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, HUNDRD + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, + $ TWO = 2.0D0, FOUR = 4.0D0, HUNDRD = 100.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL IEEE + INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K, + $ N0, NBIG, NDIV, NFAIL, PP, SPLT, TTYPE + DOUBLE PRECISION D, DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, E, + $ EMAX, EMIN, EPS, OLDEMN, QMAX, QMIN, S, SAFMIN, + $ SIGMA, T, TAU, TEMP, TOL, TOL2, TRACE, ZMAX +* .. +* .. External Subroutines .. + EXTERNAL DLAZQ3, DLASRT, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input arguments. +* (in case DLASQ2 is not called by DLASQ1) +* + INFO = 0 + EPS = DLAMCH( 'Precision' ) + SAFMIN = DLAMCH( 'Safe minimum' ) + TOL = EPS*HUNDRD + TOL2 = TOL**2 +* + IF( N.LT.0 ) THEN + INFO = -1 + CALL XERBLA( 'DLASQ2', 1 ) + RETURN + ELSE IF( N.EQ.0 ) THEN + RETURN + ELSE IF( N.EQ.1 ) THEN +* +* 1-by-1 case. +* + IF( Z( 1 ).LT.ZERO ) THEN + INFO = -201 + CALL XERBLA( 'DLASQ2', 2 ) + END IF + RETURN + ELSE IF( N.EQ.2 ) THEN +* +* 2-by-2 case. +* + IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN + INFO = -2 + CALL XERBLA( 'DLASQ2', 2 ) + RETURN + ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN + D = Z( 3 ) + Z( 3 ) = Z( 1 ) + Z( 1 ) = D + END IF + Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 ) + IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN + T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) ) + S = Z( 3 )*( Z( 2 ) / T ) + IF( S.LE.T ) THEN + S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) ) + ELSE + S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) + END IF + T = Z( 1 ) + ( S+Z( 2 ) ) + Z( 3 ) = Z( 3 )*( Z( 1 ) / T ) + Z( 1 ) = T + END IF + Z( 2 ) = Z( 3 ) + Z( 6 ) = Z( 2 ) + Z( 1 ) + RETURN + END IF +* +* Check for negative data and compute sums of q's and e's. +* + Z( 2*N ) = ZERO + EMIN = Z( 2 ) + QMAX = ZERO + ZMAX = ZERO + D = ZERO + E = ZERO +* + DO 10 K = 1, 2*( N-1 ), 2 + IF( Z( K ).LT.ZERO ) THEN + INFO = -( 200+K ) + CALL XERBLA( 'DLASQ2', 2 ) + RETURN + ELSE IF( Z( K+1 ).LT.ZERO ) THEN + INFO = -( 200+K+1 ) + CALL XERBLA( 'DLASQ2', 2 ) + RETURN + END IF + D = D + Z( K ) + E = E + Z( K+1 ) + QMAX = MAX( QMAX, Z( K ) ) + EMIN = MIN( EMIN, Z( K+1 ) ) + ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) ) + 10 CONTINUE + IF( Z( 2*N-1 ).LT.ZERO ) THEN + INFO = -( 200+2*N-1 ) + CALL XERBLA( 'DLASQ2', 2 ) + RETURN + END IF + D = D + Z( 2*N-1 ) + QMAX = MAX( QMAX, Z( 2*N-1 ) ) + ZMAX = MAX( QMAX, ZMAX ) +* +* Check for diagonality. +* + IF( E.EQ.ZERO ) THEN + DO 20 K = 2, N + Z( K ) = Z( 2*K-1 ) + 20 CONTINUE + CALL DLASRT( 'D', N, Z, IINFO ) + Z( 2*N-1 ) = D + RETURN + END IF +* + TRACE = D + E +* +* Check for zero data. +* + IF( TRACE.EQ.ZERO ) THEN + Z( 2*N-1 ) = ZERO + RETURN + END IF +* +* Check whether the machine is IEEE conformable. +* + IEEE = ILAENV( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND. + $ ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 +* +* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). +* + DO 30 K = 2*N, 2, -2 + Z( 2*K ) = ZERO + Z( 2*K-1 ) = Z( K ) + Z( 2*K-2 ) = ZERO + Z( 2*K-3 ) = Z( K-1 ) + 30 CONTINUE +* + I0 = 1 + N0 = N +* +* Reverse the qd-array, if warranted. +* + IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN + IPN4 = 4*( I0+N0 ) + DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4 + TEMP = Z( I4-3 ) + Z( I4-3 ) = Z( IPN4-I4-3 ) + Z( IPN4-I4-3 ) = TEMP + TEMP = Z( I4-1 ) + Z( I4-1 ) = Z( IPN4-I4-5 ) + Z( IPN4-I4-5 ) = TEMP + 40 CONTINUE + END IF +* +* Initial split checking via dqd and Li's test. +* + PP = 0 +* + DO 80 K = 1, 2 +* + D = Z( 4*N0+PP-3 ) + DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4 + IF( Z( I4-1 ).LE.TOL2*D ) THEN + Z( I4-1 ) = -ZERO + D = Z( I4-3 ) + ELSE + D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) ) + END IF + 50 CONTINUE +* +* dqd maps Z to ZZ plus Li's test. +* + EMIN = Z( 4*I0+PP+1 ) + D = Z( 4*I0+PP-3 ) + DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4 + Z( I4-2*PP-2 ) = D + Z( I4-1 ) + IF( Z( I4-1 ).LE.TOL2*D ) THEN + Z( I4-1 ) = -ZERO + Z( I4-2*PP-2 ) = D + Z( I4-2*PP ) = ZERO + D = Z( I4+1 ) + ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND. + $ SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN + TEMP = Z( I4+1 ) / Z( I4-2*PP-2 ) + Z( I4-2*PP ) = Z( I4-1 )*TEMP + D = D*TEMP + ELSE + Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) ) + D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) ) + END IF + EMIN = MIN( EMIN, Z( I4-2*PP ) ) + 60 CONTINUE + Z( 4*N0-PP-2 ) = D +* +* Now find qmax. +* + QMAX = Z( 4*I0-PP-2 ) + DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4 + QMAX = MAX( QMAX, Z( I4 ) ) + 70 CONTINUE +* +* Prepare for the next iteration on K. +* + PP = 1 - PP + 80 CONTINUE +* +* Initialise variables to pass to DLAZQ3 +* + TTYPE = 0 + DMIN1 = ZERO + DMIN2 = ZERO + DN = ZERO + DN1 = ZERO + DN2 = ZERO + TAU = ZERO +* + ITER = 2 + NFAIL = 0 + NDIV = 2*( N0-I0 ) +* + DO 140 IWHILA = 1, N + 1 + IF( N0.LT.1 ) + $ GO TO 150 +* +* 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 = ZERO + IF( N0.EQ.N ) THEN + SIGMA = ZERO + ELSE + SIGMA = -Z( 4*N0-1 ) + END IF + IF( SIGMA.LT.ZERO ) THEN + INFO = 1 + RETURN + END IF +* +* 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 = ZERO + IF( N0.GT.I0 ) THEN + EMIN = ABS( Z( 4*N0-5 ) ) + ELSE + EMIN = ZERO + END IF + QMIN = Z( 4*N0-3 ) + QMAX = QMIN + DO 90 I4 = 4*N0, 8, -4 + IF( Z( I4-5 ).LE.ZERO ) + $ GO TO 100 + IF( QMIN.GE.FOUR*EMAX ) THEN + QMIN = MIN( QMIN, Z( I4-3 ) ) + EMAX = MAX( EMAX, Z( I4-5 ) ) + END IF + QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) ) + EMIN = MIN( EMIN, Z( I4-5 ) ) + 90 CONTINUE + I4 = 4 +* + 100 CONTINUE + I0 = I4 / 4 +* +* Store EMIN for passing to DLAZQ3. +* + Z( 4*N0-1 ) = EMIN +* +* Put -(initial shift) into DMIN. +* + DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) ) +* +* Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong. +* + PP = 0 +* + NBIG = 30*( N0-I0+1 ) + DO 120 IWHILB = 1, NBIG + IF( I0.GT.N0 ) + $ GO TO 130 +* +* While submatrix unfinished take a good dqds step. +* + CALL DLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, + $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, + $ DN2, TAU ) +* + PP = 1 - PP +* +* When EMIN is very small check for splits. +* + IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN + IF( Z( 4*N0 ).LE.TOL2*QMAX .OR. + $ Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN + SPLT = I0 - 1 + QMAX = Z( 4*I0-3 ) + EMIN = Z( 4*I0-1 ) + OLDEMN = Z( 4*I0 ) + DO 110 I4 = 4*I0, 4*( N0-3 ), 4 + IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR. + $ Z( I4-1 ).LE.TOL2*SIGMA ) THEN + Z( I4-1 ) = -SIGMA + SPLT = I4 / 4 + QMAX = ZERO + EMIN = Z( I4+3 ) + OLDEMN = Z( I4+4 ) + ELSE + QMAX = MAX( QMAX, Z( I4+1 ) ) + EMIN = MIN( EMIN, Z( I4-1 ) ) + OLDEMN = MIN( OLDEMN, Z( I4 ) ) + END IF + 110 CONTINUE + Z( 4*N0-1 ) = EMIN + Z( 4*N0 ) = OLDEMN + I0 = SPLT + 1 + END IF + END IF +* + 120 CONTINUE +* + INFO = 2 + RETURN +* +* end IWHILB +* + 130 CONTINUE +* + 140 CONTINUE +* + INFO = 3 + RETURN +* +* end IWHILA +* + 150 CONTINUE +* +* Move q's to the front. +* + DO 160 K = 2, N + Z( K ) = Z( 4*K-3 ) + 160 CONTINUE +* +* Sort and compute sum of eigenvalues. +* + CALL DLASRT( 'D', N, Z, IINFO ) +* + E = ZERO + DO 170 K = N, 1, -1 + E = E + Z( K ) + 170 CONTINUE +* +* Store trace, sum(eigenvalues) and information on performance. +* + Z( 2*N+1 ) = TRACE + Z( 2*N+2 ) = E + Z( 2*N+3 ) = DBLE( ITER ) + Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 ) + Z( 2*N+5 ) = HUNDRD*NFAIL / DBLE( ITER ) + RETURN +* +* End of DLASQ2 +* + END diff --git a/2.3-1/src/fortran/lapack/dlasq3.f b/2.3-1/src/fortran/lapack/dlasq3.f new file mode 100644 index 00000000..ce4055d8 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlasq3.f @@ -0,0 +1,295 @@ + SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, + $ ITER, NDIV, IEEE ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER I0, ITER, N0, NDIV, NFAIL, PP + DOUBLE PRECISION DESIG, DMIN, QMAX, SIGMA +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* 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) INTEGER +* PP=0 for ping, PP=1 for pong. +* +* DMIN (output) DOUBLE PRECISION +* Minimum value of d. +* +* SIGMA (output) DOUBLE PRECISION +* Sum of shifts used in current segment. +* +* DESIG (input/output) DOUBLE PRECISION +* Lower order part of SIGMA +* +* QMAX (input) DOUBLE PRECISION +* Maximum value of q. +* +* NFAIL (output) INTEGER +* Number of times shift was too big. +* +* ITER (output) INTEGER +* Number of iterations. +* +* NDIV (output) INTEGER +* Number of divisions. +* +* TTYPE (output) INTEGER +* Shift type. +* +* IEEE (input) LOGICAL +* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION CBIAS + PARAMETER ( CBIAS = 1.50D0 ) + DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD + PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0, + $ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 ) +* .. +* .. Local Scalars .. + INTEGER IPN4, J4, N0IN, NN, TTYPE + DOUBLE PRECISION DMIN1, DMIN2, DN, DN1, DN2, EPS, S, SAFMIN, T, + $ TAU, TEMP, TOL, TOL2 +* .. +* .. External Subroutines .. + EXTERNAL DLASQ4, DLASQ5, DLASQ6 +* .. +* .. External Function .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Save statement .. + SAVE TTYPE + SAVE DMIN1, DMIN2, DN, DN1, DN2, TAU +* .. +* .. Data statement .. + DATA TTYPE / 0 / + DATA DMIN1 / ZERO /, DMIN2 / ZERO /, DN / ZERO /, + $ DN1 / ZERO /, DN2 / ZERO /, TAU / ZERO / +* .. +* .. Executable Statements .. +* + N0IN = N0 + EPS = DLAMCH( 'Precision' ) + SAFMIN = DLAMCH( 'Safe minimum' ) + TOL = EPS*HUNDRD + TOL2 = TOL**2 +* +* Check for deflation. +* + 10 CONTINUE +* + IF( N0.LT.I0 ) + $ RETURN + IF( N0.EQ.I0 ) + $ GO TO 20 + NN = 4*N0 + PP + IF( N0.EQ.( I0+1 ) ) + $ GO TO 40 +* +* Check whether E(N0-1) is negligible, 1 eigenvalue. +* + IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND. + $ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) ) + $ GO TO 30 +* + 20 CONTINUE +* + Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA + N0 = N0 - 1 + GO TO 10 +* +* Check whether E(N0-2) is negligible, 2 eigenvalues. +* + 30 CONTINUE +* + IF( Z( NN-9 ).GT.TOL2*SIGMA .AND. + $ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) ) + $ GO TO 50 +* + 40 CONTINUE +* + IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN + S = Z( NN-3 ) + Z( NN-3 ) = Z( NN-7 ) + Z( NN-7 ) = S + END IF + IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN + T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) ) + S = Z( NN-3 )*( Z( NN-5 ) / T ) + IF( S.LE.T ) THEN + S = Z( NN-3 )*( Z( NN-5 ) / + $ ( T*( ONE+SQRT( ONE+S / T ) ) ) ) + ELSE + S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) + END IF + T = Z( NN-7 ) + ( S+Z( NN-5 ) ) + Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T ) + Z( NN-7 ) = T + END IF + Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA + Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA + N0 = N0 - 2 + GO TO 10 +* + 50 CONTINUE +* +* Reverse the qd-array, if warranted. +* + IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN + IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN + IPN4 = 4*( I0+N0 ) + DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4 + TEMP = Z( J4-3 ) + Z( J4-3 ) = Z( IPN4-J4-3 ) + Z( IPN4-J4-3 ) = TEMP + TEMP = Z( J4-2 ) + Z( J4-2 ) = Z( IPN4-J4-2 ) + Z( IPN4-J4-2 ) = TEMP + TEMP = Z( J4-1 ) + Z( J4-1 ) = Z( IPN4-J4-5 ) + Z( IPN4-J4-5 ) = TEMP + TEMP = Z( J4 ) + Z( J4 ) = Z( IPN4-J4-4 ) + Z( IPN4-J4-4 ) = TEMP + 60 CONTINUE + IF( N0-I0.LE.4 ) THEN + Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 ) + Z( 4*N0-PP ) = Z( 4*I0-PP ) + END IF + DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) ) + Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ), + $ Z( 4*I0+PP+3 ) ) + Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ), + $ Z( 4*I0-PP+4 ) ) + QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) ) + DMIN = -ZERO + END IF + END IF +* + IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ), + $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN +* +* Choose a shift. +* + CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, + $ DN2, TAU, TTYPE ) +* +* Call dqds until DMIN > 0. +* + 80 CONTINUE +* + CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, IEEE ) +* + NDIV = NDIV + ( N0-I0+2 ) + ITER = ITER + 1 +* +* Check status. +* + IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN +* +* Success. +* + GO TO 100 +* + ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. + $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. + $ ABS( DN ).LT.TOL*SIGMA ) THEN +* +* Convergence hidden by negative DN. +* + Z( 4*( N0-1 )-PP+2 ) = ZERO + DMIN = ZERO + GO TO 100 + ELSE IF( DMIN.LT.ZERO ) THEN +* +* TAU too big. Select new TAU and try again. +* + NFAIL = NFAIL + 1 + IF( TTYPE.LT.-22 ) THEN +* +* Failed twice. Play it safe. +* + TAU = ZERO + ELSE IF( DMIN1.GT.ZERO ) THEN +* +* Late failure. Gives excellent shift. +* + TAU = ( TAU+DMIN )*( ONE-TWO*EPS ) + TTYPE = TTYPE - 11 + ELSE +* +* Early failure. Divide by 4. +* + TAU = QURTR*TAU + TTYPE = TTYPE - 12 + END IF + GO TO 80 + ELSE IF( DMIN.NE.DMIN ) THEN +* +* NaN. +* + TAU = ZERO + GO TO 80 + ELSE +* +* Possible underflow. Play it safe. +* + GO TO 90 + END IF + END IF +* +* Risk of underflow. +* + 90 CONTINUE + CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) + NDIV = NDIV + ( N0-I0+2 ) + ITER = ITER + 1 + TAU = ZERO +* + 100 CONTINUE + IF( TAU.LT.SIGMA ) THEN + DESIG = DESIG + TAU + T = SIGMA + DESIG + DESIG = DESIG - ( T-SIGMA ) + ELSE + T = SIGMA + TAU + DESIG = SIGMA - ( T-TAU ) + DESIG + END IF + SIGMA = T +* + RETURN +* +* End of DLASQ3 +* + END diff --git a/2.3-1/src/fortran/lapack/dlasq4.f b/2.3-1/src/fortran/lapack/dlasq4.f new file mode 100644 index 00000000..db2b6fe5 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlasq4.f @@ -0,0 +1,329 @@ + SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, TAU, TTYPE ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER I0, N0, N0IN, PP, TTYPE + DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* 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. +* +* N0IN (input) INTEGER +* The value of N0 at start of EIGTEST. +* +* DMIN (input) DOUBLE PRECISION +* Minimum value of d. +* +* DMIN1 (input) DOUBLE PRECISION +* Minimum value of d, excluding D( N0 ). +* +* DMIN2 (input) DOUBLE PRECISION +* Minimum value of d, excluding D( N0 ) and D( N0-1 ). +* +* DN (input) DOUBLE PRECISION +* d(N) +* +* DN1 (input) DOUBLE PRECISION +* d(N-1) +* +* DN2 (input) DOUBLE PRECISION +* d(N-2) +* +* TAU (output) DOUBLE PRECISION +* This is the shift. +* +* TTYPE (output) INTEGER +* Shift type. +* +* Further Details +* =============== +* CNST1 = 9/16 +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION CNST1, CNST2, CNST3 + PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0, + $ CNST3 = 1.050D0 ) + DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD + PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0, + $ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0, + $ TWO = 2.0D0, HUNDRD = 100.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I4, NN, NP + DOUBLE PRECISION A2, B1, B2, G, GAM, GAP1, GAP2, S +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Save statement .. + SAVE G +* .. +* .. Data statement .. + DATA G / ZERO / +* .. +* .. Executable Statements .. +* +* A negative DMIN forces the shift to take that absolute value +* TTYPE records the type of shift. +* + IF( DMIN.LE.ZERO ) THEN + TAU = -DMIN + TTYPE = -1 + RETURN + END IF +* + NN = 4*N0 + PP + IF( N0IN.EQ.N0 ) THEN +* +* No eigenvalues deflated. +* + IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN +* + B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) ) + B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) ) + A2 = Z( NN-7 ) + Z( NN-5 ) +* +* Cases 2 and 3. +* + IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN + GAP2 = DMIN2 - A2 - DMIN2*QURTR + IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN + GAP1 = A2 - DN - ( B2 / GAP2 )*B2 + ELSE + GAP1 = A2 - DN - ( B1+B2 ) + END IF + IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN + S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN ) + TTYPE = -2 + ELSE + S = ZERO + IF( DN.GT.B1 ) + $ S = DN - B1 + IF( A2.GT.( B1+B2 ) ) + $ S = MIN( S, A2-( B1+B2 ) ) + S = MAX( S, THIRD*DMIN ) + TTYPE = -3 + END IF + ELSE +* +* Case 4. +* + TTYPE = -4 + S = QURTR*DMIN + IF( DMIN.EQ.DN ) THEN + GAM = DN + A2 = ZERO + IF( Z( NN-5 ) .GT. Z( NN-7 ) ) + $ RETURN + B2 = Z( NN-5 ) / Z( NN-7 ) + NP = NN - 9 + ELSE + NP = NN - 2*PP + B2 = Z( NP-2 ) + GAM = DN1 + IF( Z( NP-4 ) .GT. Z( NP-2 ) ) + $ RETURN + A2 = Z( NP-4 ) / Z( NP-2 ) + IF( Z( NN-9 ) .GT. Z( NN-11 ) ) + $ RETURN + B2 = Z( NN-9 ) / Z( NN-11 ) + NP = NN - 13 + END IF +* +* Approximate contribution to norm squared from I < NN-1. +* + A2 = A2 + B2 + DO 10 I4 = NP, 4*I0 - 1 + PP, -4 + IF( B2.EQ.ZERO ) + $ GO TO 20 + B1 = B2 + IF( Z( I4 ) .GT. Z( I4-2 ) ) + $ RETURN + B2 = B2*( Z( I4 ) / Z( I4-2 ) ) + A2 = A2 + B2 + IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) + $ GO TO 20 + 10 CONTINUE + 20 CONTINUE + A2 = CNST3*A2 +* +* Rayleigh quotient residual bound. +* + IF( A2.LT.CNST1 ) + $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) + END IF + ELSE IF( DMIN.EQ.DN2 ) THEN +* +* Case 5. +* + TTYPE = -5 + S = QURTR*DMIN +* +* Compute contribution to norm squared from I > NN-2. +* + NP = NN - 2*PP + B1 = Z( NP-2 ) + B2 = Z( NP-6 ) + GAM = DN2 + IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 ) + $ RETURN + A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 ) +* +* Approximate contribution to norm squared from I < NN-2. +* + IF( N0-I0.GT.2 ) THEN + B2 = Z( NN-13 ) / Z( NN-15 ) + A2 = A2 + B2 + DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4 + IF( B2.EQ.ZERO ) + $ GO TO 40 + B1 = B2 + IF( Z( I4 ) .GT. Z( I4-2 ) ) + $ RETURN + B2 = B2*( Z( I4 ) / Z( I4-2 ) ) + A2 = A2 + B2 + IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) + $ GO TO 40 + 30 CONTINUE + 40 CONTINUE + A2 = CNST3*A2 + END IF +* + IF( A2.LT.CNST1 ) + $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) + ELSE +* +* Case 6, no information to guide us. +* + IF( TTYPE.EQ.-6 ) THEN + G = G + THIRD*( ONE-G ) + ELSE IF( TTYPE.EQ.-18 ) THEN + G = QURTR*THIRD + ELSE + G = QURTR + END IF + S = G*DMIN + TTYPE = -6 + END IF +* + ELSE IF( N0IN.EQ.( N0+1 ) ) THEN +* +* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. +* + IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN +* +* Cases 7 and 8. +* + TTYPE = -7 + S = THIRD*DMIN1 + IF( Z( NN-5 ).GT.Z( NN-7 ) ) + $ RETURN + B1 = Z( NN-5 ) / Z( NN-7 ) + B2 = B1 + IF( B2.EQ.ZERO ) + $ GO TO 60 + DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 + A2 = B1 + IF( Z( I4 ).GT.Z( I4-2 ) ) + $ RETURN + B1 = B1*( Z( I4 ) / Z( I4-2 ) ) + B2 = B2 + B1 + IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) + $ GO TO 60 + 50 CONTINUE + 60 CONTINUE + B2 = SQRT( CNST3*B2 ) + A2 = DMIN1 / ( ONE+B2**2 ) + GAP2 = HALF*DMIN2 - A2 + IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN + S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) + ELSE + S = MAX( S, A2*( ONE-CNST2*B2 ) ) + TTYPE = -8 + END IF + ELSE +* +* Case 9. +* + S = QURTR*DMIN1 + IF( DMIN1.EQ.DN1 ) + $ S = HALF*DMIN1 + TTYPE = -9 + END IF +* + ELSE IF( N0IN.EQ.( N0+2 ) ) THEN +* +* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. +* +* Cases 10 and 11. +* + IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN + TTYPE = -10 + S = THIRD*DMIN2 + IF( Z( NN-5 ).GT.Z( NN-7 ) ) + $ RETURN + B1 = Z( NN-5 ) / Z( NN-7 ) + B2 = B1 + IF( B2.EQ.ZERO ) + $ GO TO 80 + DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 + IF( Z( I4 ).GT.Z( I4-2 ) ) + $ RETURN + B1 = B1*( Z( I4 ) / Z( I4-2 ) ) + B2 = B2 + B1 + IF( HUNDRD*B1.LT.B2 ) + $ GO TO 80 + 70 CONTINUE + 80 CONTINUE + B2 = SQRT( CNST3*B2 ) + A2 = DMIN2 / ( ONE+B2**2 ) + GAP2 = Z( NN-7 ) + Z( NN-9 ) - + $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2 + IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN + S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) + ELSE + S = MAX( S, A2*( ONE-CNST2*B2 ) ) + END IF + ELSE + S = QURTR*DMIN2 + TTYPE = -11 + END IF + ELSE IF( N0IN.GT.( N0+2 ) ) THEN +* +* Case 12, more than two eigenvalues deflated. No information. +* + S = ZERO + TTYPE = -12 + END IF +* + TAU = S + RETURN +* +* End of DLASQ4 +* + END diff --git a/2.3-1/src/fortran/lapack/dlasq5.f b/2.3-1/src/fortran/lapack/dlasq5.f new file mode 100644 index 00000000..a006c99e --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlasq5.f @@ -0,0 +1,195 @@ + SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, + $ DNM1, DNM2, IEEE ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER I0, N0, PP + DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER J4, J4P2 + DOUBLE PRECISION D, EMIN, TEMP +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( ( N0-I0-1 ).LE.0 ) + $ RETURN +* + J4 = 4*I0 + PP - 3 + EMIN = Z( J4+4 ) + D = Z( J4 ) - TAU + DMIN = D + DMIN1 = -Z( J4 ) +* + IF( IEEE ) THEN +* +* Code for IEEE arithmetic. +* + IF( PP.EQ.0 ) THEN + DO 10 J4 = 4*I0, 4*( N0-3 ), 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 + EMIN = MIN( Z( J4 ), EMIN ) + 10 CONTINUE + ELSE + DO 20 J4 = 4*I0, 4*( N0-3 ), 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 + EMIN = MIN( Z( J4-1 ), EMIN ) + 20 CONTINUE + END IF +* +* Unroll last two steps. +* + DNM2 = D + DMIN2 = DMIN + J4 = 4*( N0-2 ) - PP + J4P2 = J4 + 2*PP - 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 = J4 + 4 + J4P2 = J4 + 2*PP - 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.EQ.0 ) THEN + DO 30 J4 = 4*I0, 4*( N0-3 ), 4 + Z( J4-2 ) = D + Z( J4-1 ) + IF( D.LT.ZERO ) THEN + RETURN + ELSE + Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) + D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU + END IF + DMIN = MIN( DMIN, D ) + EMIN = MIN( EMIN, Z( J4 ) ) + 30 CONTINUE + ELSE + DO 40 J4 = 4*I0, 4*( N0-3 ), 4 + Z( J4-3 ) = D + Z( J4 ) + IF( D.LT.ZERO ) THEN + RETURN + ELSE + Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) + D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU + END IF + DMIN = MIN( DMIN, D ) + EMIN = MIN( EMIN, Z( J4-1 ) ) + 40 CONTINUE + END IF +* +* Unroll last two steps. +* + DNM2 = D + DMIN2 = DMIN + J4 = 4*( N0-2 ) - PP + J4P2 = J4 + 2*PP - 1 + Z( J4-2 ) = DNM2 + Z( J4P2 ) + IF( DNM2.LT.ZERO ) THEN + RETURN + ELSE + Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) + DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU + END IF + DMIN = MIN( DMIN, DNM1 ) +* + DMIN1 = DMIN + J4 = J4 + 4 + J4P2 = J4 + 2*PP - 1 + Z( J4-2 ) = DNM1 + Z( J4P2 ) + IF( DNM1.LT.ZERO ) THEN + RETURN + ELSE + Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) + DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU + END IF + DMIN = MIN( DMIN, DN ) +* + END IF +* + Z( J4+2 ) = DN + Z( 4*N0-PP ) = EMIN + RETURN +* +* End of DLASQ5 +* + END diff --git a/2.3-1/src/fortran/lapack/dlasq6.f b/2.3-1/src/fortran/lapack/dlasq6.f new file mode 100644 index 00000000..e7eb7d0a --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlasq6.f @@ -0,0 +1,175 @@ + SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, + $ DNM1, DNM2 ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER I0, N0, PP + DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER J4, J4P2 + DOUBLE PRECISION D, EMIN, SAFMIN, TEMP +* .. +* .. External Function .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( ( N0-I0-1 ).LE.0 ) + $ RETURN +* + SAFMIN = DLAMCH( 'Safe minimum' ) + J4 = 4*I0 + PP - 3 + EMIN = Z( J4+4 ) + D = Z( J4 ) + DMIN = D +* + IF( PP.EQ.0 ) THEN + DO 10 J4 = 4*I0, 4*( N0-3 ), 4 + Z( J4-2 ) = D + Z( J4-1 ) + IF( Z( J4-2 ).EQ.ZERO ) THEN + Z( J4 ) = ZERO + D = Z( J4+1 ) + DMIN = D + EMIN = ZERO + ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND. + $ SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN + TEMP = Z( J4+1 ) / Z( J4-2 ) + Z( J4 ) = Z( J4-1 )*TEMP + D = D*TEMP + ELSE + Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) + D = Z( J4+1 )*( D / Z( J4-2 ) ) + END IF + DMIN = MIN( DMIN, D ) + EMIN = MIN( EMIN, Z( J4 ) ) + 10 CONTINUE + ELSE + DO 20 J4 = 4*I0, 4*( N0-3 ), 4 + Z( J4-3 ) = D + Z( J4 ) + IF( Z( J4-3 ).EQ.ZERO ) THEN + Z( J4-1 ) = ZERO + D = Z( J4+2 ) + DMIN = D + EMIN = ZERO + ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND. + $ SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN + TEMP = Z( J4+2 ) / Z( J4-3 ) + Z( J4-1 ) = Z( J4 )*TEMP + D = D*TEMP + ELSE + Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) + D = Z( J4+2 )*( D / Z( J4-3 ) ) + END IF + DMIN = MIN( DMIN, D ) + EMIN = MIN( EMIN, Z( J4-1 ) ) + 20 CONTINUE + END IF +* +* Unroll last two steps. +* + DNM2 = D + DMIN2 = DMIN + J4 = 4*( N0-2 ) - PP + J4P2 = J4 + 2*PP - 1 + Z( J4-2 ) = DNM2 + Z( J4P2 ) + IF( Z( J4-2 ).EQ.ZERO ) THEN + Z( J4 ) = ZERO + DNM1 = Z( J4P2+2 ) + DMIN = DNM1 + EMIN = ZERO + ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND. + $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN + 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 ) ) + END IF + DMIN = MIN( DMIN, DNM1 ) +* + DMIN1 = DMIN + J4 = J4 + 4 + J4P2 = J4 + 2*PP - 1 + Z( J4-2 ) = DNM1 + Z( J4P2 ) + IF( Z( J4-2 ).EQ.ZERO ) THEN + Z( J4 ) = ZERO + DN = Z( J4P2+2 ) + DMIN = DN + EMIN = ZERO + ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND. + $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN + 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 ) ) + END IF + DMIN = MIN( DMIN, DN ) +* + Z( J4+2 ) = DN + Z( 4*N0-PP ) = EMIN + RETURN +* +* End of DLASQ6 +* + END diff --git a/2.3-1/src/fortran/lapack/dlasr.f b/2.3-1/src/fortran/lapack/dlasr.f new file mode 100644 index 00000000..7e54bfc7 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlasr.f @@ -0,0 +1,361 @@ + SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, PIVOT, SIDE + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + DOUBLE PRECISION CTEMP, STEMP, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN + INFO = 1 + ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, + $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN + INFO = 2 + ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) + $ THEN + INFO = 3 + ELSE IF( M.LT.0 ) THEN + INFO = 4 + ELSE IF( N.LT.0 ) THEN + INFO = 5 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = 9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASR ', INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) + $ RETURN + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form P * A +* + IF( LSAME( PIVOT, 'V' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 20 J = 1, M - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 10 I = 1, N + TEMP = A( J+1, I ) + A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) + A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 40 J = M - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 30 I = 1, N + TEMP = A( J+1, I ) + A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) + A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) + 30 CONTINUE + END IF + 40 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'T' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 60 J = 2, M + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 50 I = 1, N + TEMP = A( J, I ) + A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) + A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 80 J = M, 2, -1 + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 70 I = 1, N + TEMP = A( J, I ) + A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) + A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) + 70 CONTINUE + END IF + 80 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'B' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 100 J = 1, M - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 90 I = 1, N + TEMP = A( J, I ) + A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP + A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP + 90 CONTINUE + END IF + 100 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 120 J = M - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 110 I = 1, N + TEMP = A( J, I ) + A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP + A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP + 110 CONTINUE + END IF + 120 CONTINUE + END IF + END IF + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form A * P' +* + IF( LSAME( PIVOT, 'V' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 140 J = 1, N - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 130 I = 1, M + TEMP = A( I, J+1 ) + A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) + A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) + 130 CONTINUE + END IF + 140 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 160 J = N - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 150 I = 1, M + TEMP = A( I, J+1 ) + A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) + A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) + 150 CONTINUE + END IF + 160 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'T' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 180 J = 2, N + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 170 I = 1, M + TEMP = A( I, J ) + A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) + A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) + 170 CONTINUE + END IF + 180 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 200 J = N, 2, -1 + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 190 I = 1, M + TEMP = A( I, J ) + A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) + A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) + 190 CONTINUE + END IF + 200 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'B' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 220 J = 1, N - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 210 I = 1, M + TEMP = A( I, J ) + A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP + A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP + 210 CONTINUE + END IF + 220 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 240 J = N - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 230 I = 1, M + TEMP = A( I, J ) + A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP + A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP + 230 CONTINUE + END IF + 240 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DLASR +* + END diff --git a/2.3-1/src/fortran/lapack/dlasrt.f b/2.3-1/src/fortran/lapack/dlasrt.f new file mode 100644 index 00000000..37e02178 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlasrt.f @@ -0,0 +1,243 @@ + SUBROUTINE DLASRT( ID, N, D, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER ID + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ) +* .. +* +* 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 .. + INTEGER SELECT + PARAMETER ( SELECT = 20 ) +* .. +* .. Local Scalars .. + INTEGER DIR, ENDD, I, J, START, STKPNT + DOUBLE PRECISION D1, D2, D3, DMNMX, TMP +* .. +* .. Local Arrays .. + INTEGER STACK( 2, 32 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input paramters. +* + INFO = 0 + DIR = -1 + IF( LSAME( ID, 'D' ) ) THEN + DIR = 0 + ELSE IF( LSAME( ID, 'I' ) ) THEN + DIR = 1 + END IF + IF( DIR.EQ.-1 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASRT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* + STKPNT = 1 + STACK( 1, 1 ) = 1 + STACK( 2, 1 ) = N + 10 CONTINUE + START = STACK( 1, STKPNT ) + ENDD = STACK( 2, STKPNT ) + STKPNT = STKPNT - 1 + IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN +* +* Do Insertion sort on D( START:ENDD ) +* + IF( DIR.EQ.0 ) THEN +* +* Sort into decreasing order +* + DO 30 I = START + 1, ENDD + DO 20 J = I, START + 1, -1 + IF( D( J ).GT.D( J-1 ) ) THEN + DMNMX = D( J ) + D( J ) = D( J-1 ) + D( J-1 ) = DMNMX + ELSE + GO TO 30 + END IF + 20 CONTINUE + 30 CONTINUE +* + ELSE +* +* Sort into increasing order +* + DO 50 I = START + 1, ENDD + DO 40 J = I, START + 1, -1 + IF( D( J ).LT.D( J-1 ) ) THEN + DMNMX = D( J ) + D( J ) = D( J-1 ) + D( J-1 ) = DMNMX + ELSE + GO TO 50 + END IF + 40 CONTINUE + 50 CONTINUE +* + END IF +* + ELSE IF( ENDD-START.GT.SELECT ) THEN +* +* 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.LT.D2 ) THEN + IF( D3.LT.D1 ) THEN + DMNMX = D1 + ELSE IF( D3.LT.D2 ) THEN + DMNMX = D3 + ELSE + DMNMX = D2 + END IF + ELSE + IF( D3.LT.D2 ) THEN + DMNMX = D2 + ELSE IF( D3.LT.D1 ) THEN + DMNMX = D3 + ELSE + DMNMX = D1 + END IF + END IF +* + IF( DIR.EQ.0 ) THEN +* +* Sort into decreasing order +* + I = START - 1 + J = ENDD + 1 + 60 CONTINUE + 70 CONTINUE + J = J - 1 + IF( D( J ).LT.DMNMX ) + $ GO TO 70 + 80 CONTINUE + I = I + 1 + IF( D( I ).GT.DMNMX ) + $ GO TO 80 + IF( I.LT.J ) THEN + TMP = D( I ) + D( I ) = D( J ) + D( J ) = TMP + GO TO 60 + END IF + IF( J-START.GT.ENDD-J-1 ) THEN + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = START + STACK( 2, STKPNT ) = J + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = J + 1 + STACK( 2, STKPNT ) = ENDD + ELSE + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = J + 1 + STACK( 2, STKPNT ) = ENDD + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = START + STACK( 2, STKPNT ) = J + END IF + ELSE +* +* Sort into increasing order +* + I = START - 1 + J = ENDD + 1 + 90 CONTINUE + 100 CONTINUE + J = J - 1 + IF( D( J ).GT.DMNMX ) + $ GO TO 100 + 110 CONTINUE + I = I + 1 + IF( D( I ).LT.DMNMX ) + $ GO TO 110 + IF( I.LT.J ) THEN + TMP = D( I ) + D( I ) = D( J ) + D( J ) = TMP + GO TO 90 + END IF + IF( J-START.GT.ENDD-J-1 ) THEN + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = START + STACK( 2, STKPNT ) = J + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = J + 1 + STACK( 2, STKPNT ) = ENDD + ELSE + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = J + 1 + STACK( 2, STKPNT ) = ENDD + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = START + STACK( 2, STKPNT ) = J + END IF + END IF + END IF + IF( STKPNT.GT.0 ) + $ GO TO 10 + RETURN +* +* End of DLASRT +* + END diff --git a/2.3-1/src/fortran/lapack/dlassq.f b/2.3-1/src/fortran/lapack/dlassq.f new file mode 100644 index 00000000..217e794d --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlassq.f @@ -0,0 +1,88 @@ + SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION SCALE, SUMSQ +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER IX + DOUBLE PRECISION ABSXI +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + IF( N.GT.0 ) THEN + DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX + IF( X( IX ).NE.ZERO ) THEN + ABSXI = ABS( X( IX ) ) + IF( SCALE.LT.ABSXI ) THEN + SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 + SCALE = ABSXI + ELSE + SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 + END IF + END IF + 10 CONTINUE + END IF + RETURN +* +* End of DLASSQ +* + END diff --git a/2.3-1/src/fortran/lapack/dlasv2.f b/2.3-1/src/fortran/lapack/dlasv2.f new file mode 100644 index 00000000..4a00b25d --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlasv2.f @@ -0,0 +1,249 @@ + SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) + DOUBLE PRECISION FOUR + PARAMETER ( FOUR = 4.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL GASMAL, SWAP + INTEGER PMAX + DOUBLE PRECISION A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M, + $ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN, SQRT +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. 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.GT.FA ) + IF( SWAP ) THEN + PMAX = 3 + TEMP = FT + FT = HT + HT = TEMP + TEMP = FA + FA = HA + HA = TEMP +* +* Now FA .ge. HA +* + END IF + GT = G + GA = ABS( GT ) + IF( GA.EQ.ZERO ) THEN +* +* Diagonal matrix +* + SSMIN = HA + SSMAX = FA + CLT = ONE + CRT = ONE + SLT = ZERO + SRT = ZERO + ELSE + GASMAL = .TRUE. + IF( GA.GT.FA ) THEN + PMAX = 2 + IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN +* +* Case of very large GA +* + GASMAL = .FALSE. + SSMAX = GA + IF( HA.GT.ONE ) THEN + SSMIN = FA / ( GA / HA ) + ELSE + SSMIN = ( FA / GA )*HA + END IF + CLT = ONE + SLT = HT / GT + SRT = ONE + CRT = FT / GT + END IF + END IF + IF( GASMAL ) THEN +* +* Normal case +* + D = FA - HA + IF( D.EQ.FA ) THEN +* +* Copes with infinite F or H +* + L = ONE + ELSE + L = D / FA + END IF +* +* Note that 0 .le. L .le. 1 +* + M = GT / FT +* +* Note that abs(M) .le. 1/macheps +* + T = TWO - 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.EQ.ZERO ) THEN + R = ABS( M ) + ELSE + R = SQRT( L*L+MM ) + END IF +* +* Note that 0 .le. R .le. 1 + 1/macheps +* + A = HALF*( S+R ) +* +* Note that 1 .le. A .le. 1 + abs(M) +* + SSMIN = HA / A + SSMAX = FA*A + IF( MM.EQ.ZERO ) THEN +* +* Note that M is very tiny +* + IF( L.EQ.ZERO ) THEN + T = SIGN( TWO, FT )*SIGN( ONE, GT ) + ELSE + T = GT / SIGN( D, FT ) + M / T + END IF + ELSE + T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A ) + END IF + L = SQRT( T*T+FOUR ) + CRT = TWO / L + SRT = T / L + CLT = ( CRT+SRT*M ) / A + SLT = ( HT / FT )*SRT / A + END IF + END IF + IF( SWAP ) THEN + CSL = SRT + SNL = CRT + CSR = SLT + SNR = CLT + ELSE + CSL = CLT + SNL = SLT + CSR = CRT + SNR = SRT + END IF +* +* Correct signs of SSMAX and SSMIN +* + IF( PMAX.EQ.1 ) + $ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F ) + IF( PMAX.EQ.2 ) + $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G ) + IF( PMAX.EQ.3 ) + $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H ) + SSMAX = SIGN( SSMAX, TSIGN ) + SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) ) + RETURN +* +* End of DLASV2 +* + END diff --git a/2.3-1/src/fortran/lapack/dlaswp.f b/2.3-1/src/fortran/lapack/dlaswp.f new file mode 100644 index 00000000..a11a87e9 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlaswp.f @@ -0,0 +1,119 @@ + SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, K1, K2, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* 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 .. + INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 + DOUBLE PRECISION TEMP +* .. +* .. Executable Statements .. +* +* Interchange row I with row IPIV(I) for each of rows K1 through K2. +* + IF( INCX.GT.0 ) THEN + IX0 = K1 + I1 = K1 + I2 = K2 + INC = 1 + ELSE IF( INCX.LT.0 ) THEN + IX0 = 1 + ( 1-K2 )*INCX + I1 = K2 + I2 = K1 + INC = -1 + ELSE + RETURN + END IF +* + N32 = ( N / 32 )*32 + IF( N32.NE.0 ) THEN + DO 30 J = 1, N32, 32 + IX = IX0 + DO 20 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 10 K = J, J + 31 + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 10 CONTINUE + END IF + IX = IX + INCX + 20 CONTINUE + 30 CONTINUE + END IF + IF( N32.NE.N ) THEN + N32 = N32 + 1 + IX = IX0 + DO 50 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 40 K = N32, N + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 40 CONTINUE + END IF + IX = IX + INCX + 50 CONTINUE + END IF +* + RETURN +* +* End of DLASWP +* + END diff --git a/2.3-1/src/fortran/lapack/dlasy2.f b/2.3-1/src/fortran/lapack/dlasy2.f new file mode 100644 index 00000000..3ff12070 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlasy2.f @@ -0,0 +1,381 @@ + SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, + $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL LTRANL, LTRANR + INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 + DOUBLE PRECISION SCALE, XNORM +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), + $ X( LDX, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION TWO, HALF, EIGHT + PARAMETER ( TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL BSWAP, XSWAP + INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K + DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, + $ TEMP, U11, U12, U22, XMAX +* .. +* .. Local Arrays .. + LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) + INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), + $ LOCU22( 4 ) + DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL IDAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Data statements .. + DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , + $ LOCU22 / 4, 3, 2, 1 / + DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / + DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / +* .. +* .. Executable Statements .. +* +* Do not check the input parameters for errors +* + INFO = 0 +* +* Quick return if possible +* + IF( N1.EQ.0 .OR. N2.EQ.0 ) + $ RETURN +* +* Set constants to control overflow +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + SGN = ISGN +* + K = N1 + N1 + N2 - 2 + GO TO ( 10, 20, 30, 50 )K +* +* 1 by 1: TL11*X + SGN*X*TR11 = B11 +* + 10 CONTINUE + TAU1 = TL( 1, 1 ) + SGN*TR( 1, 1 ) + BET = ABS( TAU1 ) + IF( BET.LE.SMLNUM ) THEN + TAU1 = SMLNUM + BET = SMLNUM + INFO = 1 + END IF +* + SCALE = ONE + GAM = ABS( B( 1, 1 ) ) + IF( SMLNUM*GAM.GT.BET ) + $ SCALE = ONE / GAM +* + X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 + XNORM = ABS( X( 1, 1 ) ) + RETURN +* +* 1 by 2: +* TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] +* [TR21 TR22] +* + 20 CONTINUE +* + SMIN = MAX( EPS*MAX( ABS( TL( 1, 1 ) ), ABS( TR( 1, 1 ) ), + $ ABS( TR( 1, 2 ) ), ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ), + $ SMLNUM ) + TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) + TMP( 4 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) + IF( LTRANR ) THEN + TMP( 2 ) = SGN*TR( 2, 1 ) + TMP( 3 ) = SGN*TR( 1, 2 ) + ELSE + TMP( 2 ) = SGN*TR( 1, 2 ) + TMP( 3 ) = SGN*TR( 2, 1 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 1, 2 ) + GO TO 40 +* +* 2 by 1: +* op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] +* [TL21 TL22] [X21] [X21] [B21] +* + 30 CONTINUE + SMIN = MAX( EPS*MAX( ABS( TR( 1, 1 ) ), ABS( TL( 1, 1 ) ), + $ ABS( TL( 1, 2 ) ), ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ), + $ SMLNUM ) + TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) + TMP( 4 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) + IF( LTRANL ) THEN + TMP( 2 ) = TL( 1, 2 ) + TMP( 3 ) = TL( 2, 1 ) + ELSE + TMP( 2 ) = TL( 2, 1 ) + TMP( 3 ) = TL( 1, 2 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 2, 1 ) + 40 CONTINUE +* +* Solve 2 by 2 system using complete pivoting. +* Set pivots less than SMIN to SMIN. +* + IPIV = IDAMAX( 4, TMP, 1 ) + U11 = TMP( IPIV ) + IF( ABS( U11 ).LE.SMIN ) THEN + INFO = 1 + U11 = SMIN + END IF + U12 = TMP( LOCU12( IPIV ) ) + L21 = TMP( LOCL21( IPIV ) ) / U11 + U22 = TMP( LOCU22( IPIV ) ) - U12*L21 + XSWAP = XSWPIV( IPIV ) + BSWAP = BSWPIV( IPIV ) + IF( ABS( U22 ).LE.SMIN ) THEN + INFO = 1 + U22 = SMIN + END IF + IF( BSWAP ) THEN + TEMP = BTMP( 2 ) + BTMP( 2 ) = BTMP( 1 ) - L21*TEMP + BTMP( 1 ) = TEMP + ELSE + BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) + END IF + SCALE = ONE + IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. + $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN + SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + END IF + X2( 2 ) = BTMP( 2 ) / U22 + X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) + IF( XSWAP ) THEN + TEMP = X2( 2 ) + X2( 2 ) = X2( 1 ) + X2( 1 ) = TEMP + END IF + X( 1, 1 ) = X2( 1 ) + IF( N1.EQ.1 ) THEN + X( 1, 2 ) = X2( 2 ) + XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) + ELSE + X( 2, 1 ) = X2( 2 ) + XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) ) + END IF + RETURN +* +* 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. +* + 50 CONTINUE + SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), + $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) + SMIN = MAX( SMIN, ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), + $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) + SMIN = MAX( EPS*SMIN, SMLNUM ) + BTMP( 1 ) = ZERO + CALL DCOPY( 16, BTMP, 0, T16, 1 ) + T16( 1, 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) + T16( 2, 2 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) + T16( 3, 3 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) + T16( 4, 4 ) = TL( 2, 2 ) + SGN*TR( 2, 2 ) + IF( LTRANL ) THEN + T16( 1, 2 ) = TL( 2, 1 ) + T16( 2, 1 ) = TL( 1, 2 ) + T16( 3, 4 ) = TL( 2, 1 ) + T16( 4, 3 ) = TL( 1, 2 ) + ELSE + T16( 1, 2 ) = TL( 1, 2 ) + T16( 2, 1 ) = TL( 2, 1 ) + T16( 3, 4 ) = TL( 1, 2 ) + T16( 4, 3 ) = TL( 2, 1 ) + END IF + IF( LTRANR ) THEN + T16( 1, 3 ) = SGN*TR( 1, 2 ) + T16( 2, 4 ) = SGN*TR( 1, 2 ) + T16( 3, 1 ) = SGN*TR( 2, 1 ) + T16( 4, 2 ) = SGN*TR( 2, 1 ) + ELSE + T16( 1, 3 ) = SGN*TR( 2, 1 ) + T16( 2, 4 ) = SGN*TR( 2, 1 ) + T16( 3, 1 ) = SGN*TR( 1, 2 ) + T16( 4, 2 ) = SGN*TR( 1, 2 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 2, 1 ) + BTMP( 3 ) = B( 1, 2 ) + BTMP( 4 ) = B( 2, 2 ) +* +* Perform elimination +* + DO 100 I = 1, 3 + XMAX = ZERO + DO 70 IP = I, 4 + DO 60 JP = I, 4 + IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN + XMAX = ABS( T16( IP, JP ) ) + IPSV = IP + JPSV = JP + END IF + 60 CONTINUE + 70 CONTINUE + IF( IPSV.NE.I ) THEN + CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) + TEMP = BTMP( I ) + BTMP( I ) = BTMP( IPSV ) + BTMP( IPSV ) = TEMP + END IF + IF( JPSV.NE.I ) + $ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) + JPIV( I ) = JPSV + IF( ABS( T16( I, I ) ).LT.SMIN ) THEN + INFO = 1 + T16( I, I ) = SMIN + END IF + DO 90 J = I + 1, 4 + T16( J, I ) = T16( J, I ) / T16( I, I ) + BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) + DO 80 K = I + 1, 4 + T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + IF( ABS( T16( 4, 4 ) ).LT.SMIN ) + $ T16( 4, 4 ) = SMIN + SCALE = ONE + IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN + SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), + $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), ABS( BTMP( 4 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + BTMP( 3 ) = BTMP( 3 )*SCALE + BTMP( 4 ) = BTMP( 4 )*SCALE + END IF + DO 120 I = 1, 4 + K = 5 - I + TEMP = ONE / T16( K, K ) + TMP( K ) = BTMP( K )*TEMP + DO 110 J = K + 1, 4 + TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) + 110 CONTINUE + 120 CONTINUE + DO 130 I = 1, 3 + IF( JPIV( 4-I ).NE.4-I ) THEN + TEMP = TMP( 4-I ) + TMP( 4-I ) = TMP( JPIV( 4-I ) ) + TMP( JPIV( 4-I ) ) = TEMP + END IF + 130 CONTINUE + X( 1, 1 ) = TMP( 1 ) + X( 2, 1 ) = TMP( 2 ) + X( 1, 2 ) = TMP( 3 ) + X( 2, 2 ) = TMP( 4 ) + XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 3 ) ), + $ ABS( TMP( 2 ) )+ABS( TMP( 4 ) ) ) + RETURN +* +* End of DLASY2 +* + END diff --git a/2.3-1/src/fortran/lapack/dlasyf.f b/2.3-1/src/fortran/lapack/dlasyf.f new file mode 100644 index 00000000..67b9c147 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlasyf.f @@ -0,0 +1,587 @@ + SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), W( LDW, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP, + $ KSTEP, KW + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1, + $ ROWMAX, T +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + EXTERNAL LSAME, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the trailing columns of A using the upper triangle +* of A and working backwards, and compute the matrix W = U12*D +* for use in updating A11 +* +* 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 + 10 CONTINUE + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) + $ GO TO 30 +* +* Copy column K of A to column KW of W and update it +* + CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) + IF( K.LT.N ) + $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), LDA, + $ W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) +* + 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 = ABS( W( K, KW ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value +* + IF( K.GT.1 ) THEN + IMAX = IDAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = ABS( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE + IF( ABSAKK.GE.ALPHA*COLMAX ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE +* +* Copy column IMAX to column KW-1 of W and update it +* + CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) + CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, + $ W( IMAX+1, KW-1 ), 1 ) + IF( K.LT.N ) + $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), + $ LDA, W( IMAX, KW+1 ), LDW, ONE, + $ W( 1, KW-1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value +* + JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 ) + ROWMAX = ABS( W( JMAX, KW-1 ) ) + IF( IMAX.GT.1 ) THEN + JMAX = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 ) + ROWMAX = MAX( ROWMAX, ABS( W( JMAX, KW-1 ) ) ) + END IF +* + IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE IF( ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN +* +* interchange rows and columns K and IMAX, use 1-by-1 +* pivot block +* + KP = IMAX +* +* copy column KW-1 of W to column KW +* + CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) + ELSE +* +* interchange rows and columns K-1 and IMAX, use 2-by-2 +* pivot block +* + KP = IMAX + KSTEP = 2 + END IF + END IF +* + KK = K - KSTEP + 1 + KKW = NB + KK - N +* +* Updated column KP is already stored in column KKW of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* Interchange rows KK and KP in last KK columns of A and W +* + CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) + CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), + $ LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column KW of W now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* +* Store U(k) in column k of A +* + CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + R1 = ONE / A( K, K ) + CALL DSCAL( K-1, R1, A( 1, K ), 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.GT.2 ) THEN +* +* Store U(k) and U(k-1) in columns k and k-1 of A +* + D21 = W( K-1, KW ) + D11 = W( K, KW ) / D21 + D22 = W( K-1, KW-1 ) / D21 + T = ONE / ( D11*D22-ONE ) + D21 = T / D21 + DO 20 J = 1, K - 2 + A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) + A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) + 20 CONTINUE + END IF +* +* Copy D(k) to A +* + A( K-1, K-1 ) = W( K-1, KW-1 ) + A( K-1, K ) = W( K-1, KW ) + A( K, K ) = W( K, KW ) + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -KP + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 30 CONTINUE +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 - U12*D*U12' = A11 - U12*W' +* +* computing blocks of NB columns at a time +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = J, J + JB - 1 + CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, + $ A( J, JJ ), 1 ) + 40 CONTINUE +* +* Update the rectangular superdiagonal block +* + CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, -ONE, + $ A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE, + $ A( 1, J ), LDA ) + 50 CONTINUE +* +* Put U12 in standard form by partially undoing the interchanges +* in columns k+1:n +* + J = K + 1 + 60 CONTINUE + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP + J = J + 1 + END IF + J = J + 1 + IF( JP.NE.JJ .AND. J.LE.N ) + $ CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) + IF( J.LE.N ) + $ GO TO 60 +* +* 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 + 70 CONTINUE +* +* Exit from loop +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) + $ GO TO 90 +* +* Copy column K of A to column K of W and update it +* + CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) + CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), LDA, + $ W( K, 1 ), LDW, ONE, W( K, K ), 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 = ABS( W( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value +* + IF( K.LT.N ) THEN + IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = ABS( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE + IF( ABSAKK.GE.ALPHA*COLMAX ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE +* +* Copy column IMAX to column K+1 of W and update it +* + CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 ) + CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ), + $ 1 ) + CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), + $ LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value +* + JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 ) + ROWMAX = ABS( W( JMAX, K+1 ) ) + IF( IMAX.LT.N ) THEN + JMAX = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 ) + ROWMAX = MAX( ROWMAX, ABS( W( JMAX, K+1 ) ) ) + END IF +* + IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE IF( ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN +* +* interchange rows and columns K and IMAX, use 1-by-1 +* pivot block +* + KP = IMAX +* +* copy column K+1 of W to column K +* + CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) + ELSE +* +* interchange rows and columns K+1 and IMAX, use 2-by-2 +* pivot block +* + KP = IMAX + KSTEP = 2 + END IF + END IF +* + KK = K + KSTEP - 1 +* +* Updated column KP is already stored in column KK of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) + CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) +* +* Interchange rows KK and KP in first KK columns of A and W +* + CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of W now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* +* Store L(k) in column k of A +* + CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + IF( K.LT.N ) THEN + R1 = ONE / A( K, K ) + CALL DSCAL( N-K, R1, A( K+1, K ), 1 ) + END IF + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 of W now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* + IF( K.LT.N-1 ) THEN +* +* Store L(k) and L(k+1) in columns k and k+1 of A +* + D21 = W( K+1, K ) + D11 = W( K+1, K+1 ) / D21 + D22 = W( K, K ) / D21 + T = ONE / ( D11*D22-ONE ) + D21 = T / D21 + DO 80 J = K + 2, N + A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) + A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) + 80 CONTINUE + END IF +* +* Copy D(k) to A +* + A( K, K ) = W( K, K ) + A( K+1, K ) = W( K+1, K ) + A( K+1, K+1 ) = W( K+1, K+1 ) + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -KP + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 70 +* + 90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 - L21*D*L21' = A22 - L21*W' +* +* computing blocks of NB columns at a time +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 1 + CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, + $ A( JJ, JJ ), 1 ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, + $ ONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Put L21 in standard form by partially undoing the interchanges +* in columns 1:k-1 +* + J = K - 1 + 120 CONTINUE + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP + J = J - 1 + END IF + J = J - 1 + IF( JP.NE.JJ .AND. J.GE.1 ) + $ CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) + IF( J.GE.1 ) + $ GO TO 120 +* +* Set KB to the number of columns factorized +* + KB = K - 1 +* + END IF + RETURN +* +* End of DLASYF +* + END diff --git a/2.3-1/src/fortran/lapack/dlatdf.f b/2.3-1/src/fortran/lapack/dlatdf.f new file mode 100644 index 00000000..91fa46e3 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlatdf.f @@ -0,0 +1,237 @@ + SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, + $ JPIV ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IJOB, LDZ, N + DOUBLE PRECISION RDSCAL, RDSUM +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), JPIV( * ) + DOUBLE PRECISION RHS( * ), Z( LDZ, * ) +* .. +* +* 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 .. + INTEGER MAXDIM + PARAMETER ( MAXDIM = 8 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J, K + DOUBLE PRECISION BM, BP, PMONE, SMINU, SPLUS, TEMP +* .. +* .. Local Arrays .. + INTEGER IWORK( MAXDIM ) + DOUBLE PRECISION WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGECON, DGESC2, DLASSQ, DLASWP, + $ DSCAL +* .. +* .. External Functions .. + DOUBLE PRECISION DASUM, DDOT + EXTERNAL DASUM, DDOT +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* + IF( IJOB.NE.2 ) THEN +* +* Apply permutations IPIV to RHS +* + CALL DLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 ) +* +* Solve for L-part choosing RHS either to +1 or -1. +* + PMONE = -ONE +* + DO 10 J = 1, N - 1 + BP = RHS( J ) + ONE + BM = RHS( J ) - ONE + SPLUS = ONE +* +* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and +* SMIN computed more efficiently than in BSOLVE [1]. +* + SPLUS = SPLUS + DDOT( N-J, Z( J+1, J ), 1, Z( J+1, J ), 1 ) + SMINU = DDOT( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 ) + SPLUS = SPLUS*RHS( J ) + IF( SPLUS.GT.SMINU ) THEN + RHS( J ) = BP + ELSE IF( SMINU.GT.SPLUS ) THEN + 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 ) = RHS( J ) + PMONE + PMONE = ONE + END IF +* +* Compute the remaining r.h.s. +* + TEMP = -RHS( J ) + CALL DAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 ) +* + 10 CONTINUE +* +* 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). +* + CALL DCOPY( N-1, RHS, 1, XP, 1 ) + XP( N ) = RHS( N ) + ONE + RHS( N ) = RHS( N ) - ONE + SPLUS = ZERO + SMINU = ZERO + DO 30 I = N, 1, -1 + TEMP = ONE / Z( I, I ) + XP( I ) = XP( I )*TEMP + RHS( I ) = RHS( I )*TEMP + DO 20 K = I + 1, N + XP( I ) = XP( I ) - XP( K )*( Z( I, K )*TEMP ) + RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP ) + 20 CONTINUE + SPLUS = SPLUS + ABS( XP( I ) ) + SMINU = SMINU + ABS( RHS( I ) ) + 30 CONTINUE + IF( SPLUS.GT.SMINU ) + $ CALL DCOPY( N, XP, 1, RHS, 1 ) +* +* Apply the permutations JPIV to the computed solution (RHS) +* + CALL DLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 ) +* +* Compute the sum of squares +* + CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM ) +* + ELSE +* +* IJOB = 2, Compute approximate nullvector XM of Z +* + CALL DGECON( 'I', N, Z, LDZ, ONE, TEMP, WORK, IWORK, INFO ) + CALL DCOPY( N, WORK( N+1 ), 1, XM, 1 ) +* +* Compute RHS +* + CALL DLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 ) + TEMP = ONE / SQRT( DDOT( N, XM, 1, XM, 1 ) ) + CALL DSCAL( N, TEMP, XM, 1 ) + CALL DCOPY( N, XM, 1, XP, 1 ) + CALL DAXPY( N, ONE, RHS, 1, XP, 1 ) + CALL DAXPY( N, -ONE, XM, 1, RHS, 1 ) + CALL DGESC2( N, Z, LDZ, RHS, IPIV, JPIV, TEMP ) + CALL DGESC2( N, Z, LDZ, XP, IPIV, JPIV, TEMP ) + IF( DASUM( N, XP, 1 ).GT.DASUM( N, RHS, 1 ) ) + $ CALL DCOPY( N, XP, 1, RHS, 1 ) +* +* Compute the sum of squares +* + CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM ) +* + END IF +* + RETURN +* +* End of DLATDF +* + END diff --git a/2.3-1/src/fortran/lapack/dlatrd.f b/2.3-1/src/fortran/lapack/dlatrd.f new file mode 100644 index 00000000..27bf9b98 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlatrd.f @@ -0,0 +1,258 @@ + SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDW, N, NB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IW + DOUBLE PRECISION ALPHA +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DGEMV, DLARFG, DSCAL, DSYMV +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Reduce last NB columns of upper triangle +* + DO 10 I = N, N - NB + 1, -1 + IW = I - N + NB + IF( I.LT.N ) THEN +* +* Update A(1:i,i) +* + CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), + $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) + CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), + $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) + END IF + IF( I.GT.1 ) THEN +* +* Generate elementary reflector H(i) to annihilate +* A(1:i-2,i) +* + CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) ) + E( I-1 ) = A( I-1, I ) + A( I-1, I ) = ONE +* +* Compute W(1:i-1,i) +* + CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, + $ ZERO, W( 1, IW ), 1 ) + IF( I.LT.N ) THEN + CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ), + $ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, -ONE, + $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, + $ W( 1, IW ), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), + $ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, -ONE, + $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, + $ W( 1, IW ), 1 ) + END IF + CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) + ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1, + $ A( 1, I ), 1 ) + CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) + END IF +* + 10 CONTINUE + ELSE +* +* Reduce first NB columns of lower triangle +* + DO 20 I = 1, NB +* +* Update A(i:n,i) +* + CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), + $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) + CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), + $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) + IF( I.LT.N ) THEN +* +* Generate elementary reflector H(i) to annihilate +* A(i+2:n,i) +* + CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAU( I ) ) + E( I ) = A( I+1, I ) + A( I+1, I ) = ONE +* +* Compute W(i+1:n,i) +* + CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, + $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW, + $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), + $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, + $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), + $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) + CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) + ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1, + $ A( I+1, I ), 1 ) + CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) + END IF +* + 20 CONTINUE + END IF +* + RETURN +* +* End of DLATRD +* + END diff --git a/2.3-1/src/fortran/lapack/dlatrs.f b/2.3-1/src/fortran/lapack/dlatrs.f new file mode 100644 index 00000000..bbd3a9e4 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlatrs.f @@ -0,0 +1,701 @@ + SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, + $ CNORM, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIAG, NORMIN, TRANS, UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN, NOUNIT, UPPER + INTEGER I, IMAX, J, JFIRST, JINC, JLAST + DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS, + $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DASUM, DDOT, DLAMCH + EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DSCAL, DTRSV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + NOTRAN = LSAME( TRANS, 'N' ) + NOUNIT = LSAME( DIAG, 'N' ) +* +* Test the input parameters. +* + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN + INFO = -3 + ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. + $ LSAME( NORMIN, 'N' ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLATRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine machine dependent parameters to control overflow. +* + SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + SCALE = ONE +* + IF( LSAME( NORMIN, 'N' ) ) THEN +* +* Compute the 1-norm of each column, not including the diagonal. +* + IF( UPPER ) THEN +* +* A is upper triangular. +* + DO 10 J = 1, N + CNORM( J ) = DASUM( J-1, A( 1, J ), 1 ) + 10 CONTINUE + ELSE +* +* A is lower triangular. +* + DO 20 J = 1, N - 1 + CNORM( J ) = DASUM( N-J, A( J+1, J ), 1 ) + 20 CONTINUE + CNORM( N ) = ZERO + END IF + END IF +* +* Scale the column norms by TSCAL if the maximum element in CNORM is +* greater than BIGNUM. +* + IMAX = IDAMAX( N, CNORM, 1 ) + TMAX = CNORM( IMAX ) + IF( TMAX.LE.BIGNUM ) THEN + TSCAL = ONE + ELSE + TSCAL = ONE / ( SMLNUM*TMAX ) + CALL DSCAL( N, TSCAL, CNORM, 1 ) + END IF +* +* 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 ) + XMAX = ABS( X( J ) ) + XBND = XMAX + IF( NOTRAN ) THEN +* +* Compute the growth in A * x = b. +* + IF( UPPER ) THEN + JFIRST = N + JLAST = 1 + JINC = -1 + ELSE + JFIRST = 1 + JLAST = N + JINC = 1 + END IF +* + IF( TSCAL.NE.ONE ) THEN + GROW = ZERO + GO TO 50 + END IF +* + IF( NOUNIT ) THEN +* +* 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 = ONE / MAX( XBND, SMLNUM ) + XBND = GROW + DO 30 J = JFIRST, JLAST, JINC +* +* Exit the loop if the growth factor is too small. +* + IF( GROW.LE.SMLNUM ) + $ GO TO 50 +* +* M(j) = G(j-1) / abs(A(j,j)) +* + TJJ = ABS( A( J, J ) ) + XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) + IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN +* +* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) +* + GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) + ELSE +* +* G(j) could overflow, set GROW to 0. +* + GROW = ZERO + END IF + 30 CONTINUE + GROW = XBND + ELSE +* +* A is unit triangular. +* +* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. +* + GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) + DO 40 J = JFIRST, JLAST, JINC +* +* Exit the loop if the growth factor is too small. +* + IF( GROW.LE.SMLNUM ) + $ GO TO 50 +* +* G(j) = G(j-1)*( 1 + CNORM(j) ) +* + GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) + 40 CONTINUE + END IF + 50 CONTINUE +* + ELSE +* +* Compute the growth in A' * x = b. +* + IF( UPPER ) THEN + JFIRST = 1 + JLAST = N + JINC = 1 + ELSE + JFIRST = N + JLAST = 1 + JINC = -1 + END IF +* + IF( TSCAL.NE.ONE ) THEN + GROW = ZERO + GO TO 80 + END IF +* + IF( NOUNIT ) THEN +* +* 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 = ONE / MAX( XBND, SMLNUM ) + XBND = GROW + DO 60 J = JFIRST, JLAST, JINC +* +* Exit the loop if the growth factor is too small. +* + IF( GROW.LE.SMLNUM ) + $ GO TO 80 +* +* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) +* + XJ = ONE + CNORM( J ) + GROW = MIN( GROW, XBND / XJ ) +* +* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) +* + TJJ = ABS( A( J, J ) ) + IF( XJ.GT.TJJ ) + $ XBND = XBND*( TJJ / XJ ) + 60 CONTINUE + GROW = MIN( GROW, XBND ) + ELSE +* +* A is unit triangular. +* +* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. +* + GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) + DO 70 J = JFIRST, JLAST, JINC +* +* Exit the loop if the growth factor is too small. +* + IF( GROW.LE.SMLNUM ) + $ GO TO 80 +* +* G(j) = ( 1 + CNORM(j) )*G(j-1) +* + XJ = ONE + CNORM( J ) + GROW = GROW / XJ + 70 CONTINUE + END IF + 80 CONTINUE + END IF +* + IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN +* +* Use the Level 2 BLAS solve if the reciprocal of the bound on +* elements of X is not too small. +* + CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) + ELSE +* +* Use a Level 1 BLAS solve, scaling intermediate results. +* + IF( XMAX.GT.BIGNUM ) THEN +* +* Scale X so that its components are less than or equal to +* BIGNUM in absolute value. +* + SCALE = BIGNUM / XMAX + CALL DSCAL( N, SCALE, X, 1 ) + XMAX = BIGNUM + END IF +* + IF( NOTRAN ) THEN +* +* Solve A * x = b +* + DO 110 J = JFIRST, JLAST, JINC +* +* Compute x(j) = b(j) / A(j,j), scaling x if necessary. +* + XJ = ABS( X( J ) ) + IF( NOUNIT ) THEN + TJJS = A( J, J )*TSCAL + ELSE + TJJS = TSCAL + IF( TSCAL.EQ.ONE ) + $ GO TO 100 + END IF + TJJ = ABS( TJJS ) + IF( TJJ.GT.SMLNUM ) THEN +* +* abs(A(j,j)) > SMLNUM: +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale x by 1/b(j). +* + REC = ONE / XJ + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + X( J ) = X( J ) / TJJS + XJ = ABS( X( J ) ) + ELSE IF( TJJ.GT.ZERO ) THEN +* +* 0 < abs(A(j,j)) <= SMLNUM: +* + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* 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 ).GT.ONE ) THEN +* +* Scale by 1/CNORM(j) to avoid overflow when +* multiplying x(j) times column j. +* + REC = REC / CNORM( J ) + END IF + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + X( J ) = X( J ) / TJJS + XJ = ABS( X( J ) ) + ELSE +* +* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and +* scale = 0, and compute a solution to A*x = 0. +* + DO 90 I = 1, N + X( I ) = ZERO + 90 CONTINUE + X( J ) = ONE + XJ = ONE + SCALE = ZERO + XMAX = ZERO + END IF + 100 CONTINUE +* +* Scale x if necessary to avoid overflow when adding a +* multiple of column j of A. +* + IF( XJ.GT.ONE ) THEN + REC = ONE / XJ + IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN +* +* Scale x by 1/(2*abs(x(j))). +* + REC = REC*HALF + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + END IF + ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN +* +* Scale x by 1/2. +* + CALL DSCAL( N, HALF, X, 1 ) + SCALE = SCALE*HALF + END IF +* + IF( UPPER ) THEN + IF( J.GT.1 ) THEN +* +* Compute the update +* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) +* + CALL DAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, + $ 1 ) + I = IDAMAX( J-1, X, 1 ) + XMAX = ABS( X( I ) ) + END IF + ELSE + IF( J.LT.N ) THEN +* +* Compute the update +* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) +* + CALL DAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, + $ X( J+1 ), 1 ) + I = J + IDAMAX( N-J, X( J+1 ), 1 ) + XMAX = ABS( X( I ) ) + END IF + END IF + 110 CONTINUE +* + ELSE +* +* Solve A' * x = b +* + DO 160 J = JFIRST, JLAST, JINC +* +* Compute x(j) = b(j) - sum A(k,j)*x(k). +* k<>j +* + XJ = ABS( X( J ) ) + USCAL = TSCAL + REC = ONE / MAX( XMAX, ONE ) + IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN +* +* If x(j) could overflow, scale x by 1/(2*XMAX). +* + REC = REC*HALF + IF( NOUNIT ) THEN + TJJS = A( J, J )*TSCAL + ELSE + TJJS = TSCAL + END IF + TJJ = ABS( TJJS ) + IF( TJJ.GT.ONE ) THEN +* +* Divide by A(j,j) when scaling x if A(j,j) > 1. +* + REC = MIN( ONE, REC*TJJ ) + USCAL = USCAL / TJJS + END IF + IF( REC.LT.ONE ) THEN + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF +* + SUMJ = ZERO + IF( USCAL.EQ.ONE ) THEN +* +* If the scaling needed for A in the dot product is 1, +* call DDOT to perform the dot product. +* + IF( UPPER ) THEN + SUMJ = DDOT( J-1, A( 1, J ), 1, X, 1 ) + ELSE IF( J.LT.N ) THEN + SUMJ = DDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) + END IF + ELSE +* +* Otherwise, use in-line code for the dot product. +* + IF( UPPER ) THEN + DO 120 I = 1, J - 1 + SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I ) + 120 CONTINUE + ELSE IF( J.LT.N ) THEN + DO 130 I = J + 1, N + SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I ) + 130 CONTINUE + END IF + END IF +* + IF( USCAL.EQ.TSCAL ) THEN +* +* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) +* was not used to scale the dotproduct. +* + X( J ) = X( J ) - SUMJ + XJ = ABS( X( J ) ) + IF( NOUNIT ) THEN + TJJS = A( J, J )*TSCAL + ELSE + TJJS = TSCAL + IF( TSCAL.EQ.ONE ) + $ GO TO 150 + END IF +* +* Compute x(j) = x(j) / A(j,j), scaling if necessary. +* + TJJ = ABS( TJJS ) + IF( TJJ.GT.SMLNUM ) THEN +* +* abs(A(j,j)) > SMLNUM: +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale X by 1/abs(x(j)). +* + REC = ONE / XJ + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + X( J ) = X( J ) / TJJS + ELSE IF( TJJ.GT.ZERO ) THEN +* +* 0 < abs(A(j,j)) <= SMLNUM: +* + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. +* + REC = ( TJJ*BIGNUM ) / XJ + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + X( J ) = 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. +* + DO 140 I = 1, N + X( I ) = ZERO + 140 CONTINUE + X( J ) = ONE + SCALE = ZERO + XMAX = ZERO + END IF + 150 CONTINUE + 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 + END IF + XMAX = MAX( XMAX, ABS( X( J ) ) ) + 160 CONTINUE + END IF + SCALE = SCALE / TSCAL + END IF +* +* Scale the column norms by 1/TSCAL for return. +* + IF( TSCAL.NE.ONE ) THEN + CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) + END IF +* + RETURN +* +* End of DLATRS +* + END diff --git a/2.3-1/src/fortran/lapack/dlatrz.f b/2.3-1/src/fortran/lapack/dlatrz.f new file mode 100644 index 00000000..e1a2cf97 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlatrz.f @@ -0,0 +1,127 @@ + SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER L, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. External Subroutines .. + EXTERNAL DLARFG, DLARZ +* .. +* .. Executable Statements .. +* +* Test the input arguments +* +* Quick return if possible +* + IF( M.EQ.0 ) THEN + RETURN + ELSE IF( M.EQ.N ) THEN + DO 10 I = 1, N + TAU( I ) = ZERO + 10 CONTINUE + RETURN + END IF +* + DO 20 I = M, 1, -1 +* +* Generate elementary reflector H(i) to annihilate +* [ A(i,i) A(i,n-l+1:n) ] +* + CALL DLARFG( L+1, A( I, I ), A( I, N-L+1 ), LDA, TAU( I ) ) +* +* Apply H(i) to A(1:i-1,i:n) from the right +* + CALL DLARZ( 'Right', I-1, N-I+1, L, A( I, N-L+1 ), LDA, + $ TAU( I ), A( 1, I ), LDA, WORK ) +* + 20 CONTINUE +* + RETURN +* +* End of DLATRZ +* + END diff --git a/2.3-1/src/fortran/lapack/dlatzm.f b/2.3-1/src/fortran/lapack/dlatzm.f new file mode 100644 index 00000000..2467ab60 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlatzm.f @@ -0,0 +1,142 @@ + SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( ( MIN( M, N ).EQ.0 ) .OR. ( TAU.EQ.ZERO ) ) + $ RETURN +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* w := C1 + v' * C2 +* + CALL DCOPY( N, C1, LDC, WORK, 1 ) + CALL DGEMV( 'Transpose', M-1, N, ONE, C2, LDC, V, INCV, ONE, + $ WORK, 1 ) +* +* [ C1 ] := [ C1 ] - tau* [ 1 ] * w' +* [ C2 ] [ C2 ] [ v ] +* + CALL DAXPY( N, -TAU, WORK, 1, C1, LDC ) + CALL DGER( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC ) +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* w := C1 + C2 * v +* + CALL DCOPY( M, C1, 1, WORK, 1 ) + CALL DGEMV( 'No transpose', M, N-1, ONE, C2, LDC, V, INCV, ONE, + $ WORK, 1 ) +* +* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v'] +* + CALL DAXPY( M, -TAU, WORK, 1, C1, 1 ) + CALL DGER( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC ) + END IF +* + RETURN +* +* End of DLATZM +* + END diff --git a/2.3-1/src/fortran/lapack/dlazq3.f b/2.3-1/src/fortran/lapack/dlazq3.f new file mode 100644 index 00000000..784248f7 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlazq3.f @@ -0,0 +1,302 @@ + SUBROUTINE DLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, + $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, + $ DN2, TAU ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER I0, ITER, N0, NDIV, NFAIL, PP, TTYPE + DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, QMAX, + $ SIGMA, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* Purpose +* ======= +* +* DLAZQ3 checks for deflation, computes a shift (TAU) and calls dqds. +* In case of failure it changes shifts, and tries again until output +* is positive. +* +* Arguments +* ========= +* +* I0 (input) INTEGER +* First index. +* +* N0 (input) INTEGER +* Last index. +* +* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) +* Z holds the qd array. +* +* PP (input) INTEGER +* PP=0 for ping, PP=1 for pong. +* +* DMIN (output) DOUBLE PRECISION +* Minimum value of d. +* +* SIGMA (output) DOUBLE PRECISION +* Sum of shifts used in current segment. +* +* DESIG (input/output) DOUBLE PRECISION +* Lower order part of SIGMA +* +* QMAX (input) DOUBLE PRECISION +* Maximum value of q. +* +* NFAIL (output) INTEGER +* Number of times shift was too big. +* +* ITER (output) INTEGER +* Number of iterations. +* +* NDIV (output) INTEGER +* Number of divisions. +* +* IEEE (input) LOGICAL +* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). +* +* TTYPE (input/output) INTEGER +* Shift type. TTYPE is passed as an argument in order to save +* its value between calls to DLAZQ3 +* +* DMIN1 (input/output) REAL +* DMIN2 (input/output) REAL +* DN (input/output) REAL +* DN1 (input/output) REAL +* DN2 (input/output) REAL +* TAU (input/output) REAL +* These are passed as arguments in order to save their values +* between calls to DLAZQ3 +* +* This is a thread safe version of DLASQ3, which passes TTYPE, DMIN1, +* DMIN2, DN, DN1. DN2 and TAU through the argument list in place of +* declaring them in a SAVE statment. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION CBIAS + PARAMETER ( CBIAS = 1.50D0 ) + DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD + PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0, + $ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 ) +* .. +* .. Local Scalars .. + INTEGER IPN4, J4, N0IN, NN + DOUBLE PRECISION EPS, G, S, SAFMIN, T, TEMP, TOL, TOL2 +* .. +* .. External Subroutines .. + EXTERNAL DLASQ5, DLASQ6, DLAZQ4 +* .. +* .. External Function .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MIN, SQRT +* .. +* .. Executable Statements .. +* + N0IN = N0 + EPS = DLAMCH( 'Precision' ) + SAFMIN = DLAMCH( 'Safe minimum' ) + TOL = EPS*HUNDRD + TOL2 = TOL**2 + G = ZERO +* +* Check for deflation. +* + 10 CONTINUE +* + IF( N0.LT.I0 ) + $ RETURN + IF( N0.EQ.I0 ) + $ GO TO 20 + NN = 4*N0 + PP + IF( N0.EQ.( I0+1 ) ) + $ GO TO 40 +* +* Check whether E(N0-1) is negligible, 1 eigenvalue. +* + IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND. + $ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) ) + $ GO TO 30 +* + 20 CONTINUE +* + Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA + N0 = N0 - 1 + GO TO 10 +* +* Check whether E(N0-2) is negligible, 2 eigenvalues. +* + 30 CONTINUE +* + IF( Z( NN-9 ).GT.TOL2*SIGMA .AND. + $ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) ) + $ GO TO 50 +* + 40 CONTINUE +* + IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN + S = Z( NN-3 ) + Z( NN-3 ) = Z( NN-7 ) + Z( NN-7 ) = S + END IF + IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN + T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) ) + S = Z( NN-3 )*( Z( NN-5 ) / T ) + IF( S.LE.T ) THEN + S = Z( NN-3 )*( Z( NN-5 ) / + $ ( T*( ONE+SQRT( ONE+S / T ) ) ) ) + ELSE + S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) + END IF + T = Z( NN-7 ) + ( S+Z( NN-5 ) ) + Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T ) + Z( NN-7 ) = T + END IF + Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA + Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA + N0 = N0 - 2 + GO TO 10 +* + 50 CONTINUE +* +* Reverse the qd-array, if warranted. +* + IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN + IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN + IPN4 = 4*( I0+N0 ) + DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4 + TEMP = Z( J4-3 ) + Z( J4-3 ) = Z( IPN4-J4-3 ) + Z( IPN4-J4-3 ) = TEMP + TEMP = Z( J4-2 ) + Z( J4-2 ) = Z( IPN4-J4-2 ) + Z( IPN4-J4-2 ) = TEMP + TEMP = Z( J4-1 ) + Z( J4-1 ) = Z( IPN4-J4-5 ) + Z( IPN4-J4-5 ) = TEMP + TEMP = Z( J4 ) + Z( J4 ) = Z( IPN4-J4-4 ) + Z( IPN4-J4-4 ) = TEMP + 60 CONTINUE + IF( N0-I0.LE.4 ) THEN + Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 ) + Z( 4*N0-PP ) = Z( 4*I0-PP ) + END IF + DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) ) + Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ), + $ Z( 4*I0+PP+3 ) ) + Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ), + $ Z( 4*I0-PP+4 ) ) + QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) ) + DMIN = -ZERO + END IF + END IF +* + IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ), + $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN +* +* Choose a shift. +* + CALL DLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, + $ DN2, TAU, TTYPE, G ) +* +* Call dqds until DMIN > 0. +* + 80 CONTINUE +* + CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, IEEE ) +* + NDIV = NDIV + ( N0-I0+2 ) + ITER = ITER + 1 +* +* Check status. +* + IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN +* +* Success. +* + GO TO 100 +* + ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. + $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. + $ ABS( DN ).LT.TOL*SIGMA ) THEN +* +* Convergence hidden by negative DN. +* + Z( 4*( N0-1 )-PP+2 ) = ZERO + DMIN = ZERO + GO TO 100 + ELSE IF( DMIN.LT.ZERO ) THEN +* +* TAU too big. Select new TAU and try again. +* + NFAIL = NFAIL + 1 + IF( TTYPE.LT.-22 ) THEN +* +* Failed twice. Play it safe. +* + TAU = ZERO + ELSE IF( DMIN1.GT.ZERO ) THEN +* +* Late failure. Gives excellent shift. +* + TAU = ( TAU+DMIN )*( ONE-TWO*EPS ) + TTYPE = TTYPE - 11 + ELSE +* +* Early failure. Divide by 4. +* + TAU = QURTR*TAU + TTYPE = TTYPE - 12 + END IF + GO TO 80 + ELSE IF( DMIN.NE.DMIN ) THEN +* +* NaN. +* + TAU = ZERO + GO TO 80 + ELSE +* +* Possible underflow. Play it safe. +* + GO TO 90 + END IF + END IF +* +* Risk of underflow. +* + 90 CONTINUE + CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) + NDIV = NDIV + ( N0-I0+2 ) + ITER = ITER + 1 + TAU = ZERO +* + 100 CONTINUE + IF( TAU.LT.SIGMA ) THEN + DESIG = DESIG + TAU + T = SIGMA + DESIG + DESIG = DESIG - ( T-SIGMA ) + ELSE + T = SIGMA + TAU + DESIG = SIGMA - ( T-TAU ) + DESIG + END IF + SIGMA = T +* + RETURN +* +* End of DLAZQ3 +* + END diff --git a/2.3-1/src/fortran/lapack/dlazq4.f b/2.3-1/src/fortran/lapack/dlazq4.f new file mode 100644 index 00000000..7c257f8d --- /dev/null +++ b/2.3-1/src/fortran/lapack/dlazq4.f @@ -0,0 +1,330 @@ + SUBROUTINE DLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, TAU, TTYPE, G ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER I0, N0, N0IN, PP, TTYPE + DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* Purpose +* ======= +* +* DLAZQ4 computes an approximation TAU to the smallest eigenvalue +* using values of d from the previous transform. +* +* I0 (input) INTEGER +* First index. +* +* N0 (input) INTEGER +* Last index. +* +* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) +* Z holds the qd array. +* +* PP (input) INTEGER +* PP=0 for ping, PP=1 for pong. +* +* N0IN (input) INTEGER +* The value of N0 at start of EIGTEST. +* +* DMIN (input) DOUBLE PRECISION +* Minimum value of d. +* +* DMIN1 (input) DOUBLE PRECISION +* Minimum value of d, excluding D( N0 ). +* +* DMIN2 (input) DOUBLE PRECISION +* Minimum value of d, excluding D( N0 ) and D( N0-1 ). +* +* DN (input) DOUBLE PRECISION +* d(N) +* +* DN1 (input) DOUBLE PRECISION +* d(N-1) +* +* DN2 (input) DOUBLE PRECISION +* d(N-2) +* +* TAU (output) DOUBLE PRECISION +* This is the shift. +* +* TTYPE (output) INTEGER +* Shift type. +* +* G (input/output) DOUBLE PRECISION +* G is passed as an argument in order to save its value between +* calls to DLAZQ4 +* +* Further Details +* =============== +* CNST1 = 9/16 +* +* This is a thread safe version of DLASQ4, which passes G through the +* argument list in place of declaring G in a SAVE statment. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION CNST1, CNST2, CNST3 + PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0, + $ CNST3 = 1.050D0 ) + DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD + PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0, + $ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0, + $ TWO = 2.0D0, HUNDRD = 100.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I4, NN, NP + DOUBLE PRECISION A2, B1, B2, GAM, GAP1, GAP2, S +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* A negative DMIN forces the shift to take that absolute value +* TTYPE records the type of shift. +* + IF( DMIN.LE.ZERO ) THEN + TAU = -DMIN + TTYPE = -1 + RETURN + END IF +* + NN = 4*N0 + PP + IF( N0IN.EQ.N0 ) THEN +* +* No eigenvalues deflated. +* + IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN +* + B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) ) + B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) ) + A2 = Z( NN-7 ) + Z( NN-5 ) +* +* Cases 2 and 3. +* + IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN + GAP2 = DMIN2 - A2 - DMIN2*QURTR + IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN + GAP1 = A2 - DN - ( B2 / GAP2 )*B2 + ELSE + GAP1 = A2 - DN - ( B1+B2 ) + END IF + IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN + S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN ) + TTYPE = -2 + ELSE + S = ZERO + IF( DN.GT.B1 ) + $ S = DN - B1 + IF( A2.GT.( B1+B2 ) ) + $ S = MIN( S, A2-( B1+B2 ) ) + S = MAX( S, THIRD*DMIN ) + TTYPE = -3 + END IF + ELSE +* +* Case 4. +* + TTYPE = -4 + S = QURTR*DMIN + IF( DMIN.EQ.DN ) THEN + GAM = DN + A2 = ZERO + IF( Z( NN-5 ) .GT. Z( NN-7 ) ) + $ RETURN + B2 = Z( NN-5 ) / Z( NN-7 ) + NP = NN - 9 + ELSE + NP = NN - 2*PP + B2 = Z( NP-2 ) + GAM = DN1 + IF( Z( NP-4 ) .GT. Z( NP-2 ) ) + $ RETURN + A2 = Z( NP-4 ) / Z( NP-2 ) + IF( Z( NN-9 ) .GT. Z( NN-11 ) ) + $ RETURN + B2 = Z( NN-9 ) / Z( NN-11 ) + NP = NN - 13 + END IF +* +* Approximate contribution to norm squared from I < NN-1. +* + A2 = A2 + B2 + DO 10 I4 = NP, 4*I0 - 1 + PP, -4 + IF( B2.EQ.ZERO ) + $ GO TO 20 + B1 = B2 + IF( Z( I4 ) .GT. Z( I4-2 ) ) + $ RETURN + B2 = B2*( Z( I4 ) / Z( I4-2 ) ) + A2 = A2 + B2 + IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) + $ GO TO 20 + 10 CONTINUE + 20 CONTINUE + A2 = CNST3*A2 +* +* Rayleigh quotient residual bound. +* + IF( A2.LT.CNST1 ) + $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) + END IF + ELSE IF( DMIN.EQ.DN2 ) THEN +* +* Case 5. +* + TTYPE = -5 + S = QURTR*DMIN +* +* Compute contribution to norm squared from I > NN-2. +* + NP = NN - 2*PP + B1 = Z( NP-2 ) + B2 = Z( NP-6 ) + GAM = DN2 + IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 ) + $ RETURN + A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 ) +* +* Approximate contribution to norm squared from I < NN-2. +* + IF( N0-I0.GT.2 ) THEN + B2 = Z( NN-13 ) / Z( NN-15 ) + A2 = A2 + B2 + DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4 + IF( B2.EQ.ZERO ) + $ GO TO 40 + B1 = B2 + IF( Z( I4 ) .GT. Z( I4-2 ) ) + $ RETURN + B2 = B2*( Z( I4 ) / Z( I4-2 ) ) + A2 = A2 + B2 + IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) + $ GO TO 40 + 30 CONTINUE + 40 CONTINUE + A2 = CNST3*A2 + END IF +* + IF( A2.LT.CNST1 ) + $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) + ELSE +* +* Case 6, no information to guide us. +* + IF( TTYPE.EQ.-6 ) THEN + G = G + THIRD*( ONE-G ) + ELSE IF( TTYPE.EQ.-18 ) THEN + G = QURTR*THIRD + ELSE + G = QURTR + END IF + S = G*DMIN + TTYPE = -6 + END IF +* + ELSE IF( N0IN.EQ.( N0+1 ) ) THEN +* +* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. +* + IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN +* +* Cases 7 and 8. +* + TTYPE = -7 + S = THIRD*DMIN1 + IF( Z( NN-5 ).GT.Z( NN-7 ) ) + $ RETURN + B1 = Z( NN-5 ) / Z( NN-7 ) + B2 = B1 + IF( B2.EQ.ZERO ) + $ GO TO 60 + DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 + A2 = B1 + IF( Z( I4 ).GT.Z( I4-2 ) ) + $ RETURN + B1 = B1*( Z( I4 ) / Z( I4-2 ) ) + B2 = B2 + B1 + IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) + $ GO TO 60 + 50 CONTINUE + 60 CONTINUE + B2 = SQRT( CNST3*B2 ) + A2 = DMIN1 / ( ONE+B2**2 ) + GAP2 = HALF*DMIN2 - A2 + IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN + S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) + ELSE + S = MAX( S, A2*( ONE-CNST2*B2 ) ) + TTYPE = -8 + END IF + ELSE +* +* Case 9. +* + S = QURTR*DMIN1 + IF( DMIN1.EQ.DN1 ) + $ S = HALF*DMIN1 + TTYPE = -9 + END IF +* + ELSE IF( N0IN.EQ.( N0+2 ) ) THEN +* +* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. +* +* Cases 10 and 11. +* + IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN + TTYPE = -10 + S = THIRD*DMIN2 + IF( Z( NN-5 ).GT.Z( NN-7 ) ) + $ RETURN + B1 = Z( NN-5 ) / Z( NN-7 ) + B2 = B1 + IF( B2.EQ.ZERO ) + $ GO TO 80 + DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 + IF( Z( I4 ).GT.Z( I4-2 ) ) + $ RETURN + B1 = B1*( Z( I4 ) / Z( I4-2 ) ) + B2 = B2 + B1 + IF( HUNDRD*B1.LT.B2 ) + $ GO TO 80 + 70 CONTINUE + 80 CONTINUE + B2 = SQRT( CNST3*B2 ) + A2 = DMIN2 / ( ONE+B2**2 ) + GAP2 = Z( NN-7 ) + Z( NN-9 ) - + $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2 + IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN + S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) + ELSE + S = MAX( S, A2*( ONE-CNST2*B2 ) ) + END IF + ELSE + S = QURTR*DMIN2 + TTYPE = -11 + END IF + ELSE IF( N0IN.GT.( N0+2 ) ) THEN +* +* Case 12, more than two eigenvalues deflated. No information. +* + S = ZERO + TTYPE = -12 + END IF +* + TAU = S + RETURN +* +* End of DLAZQ4 +* + END diff --git a/2.3-1/src/fortran/lapack/dopgtr.f b/2.3-1/src/fortran/lapack/dopgtr.f new file mode 100644 index 00000000..cf0901ff --- /dev/null +++ b/2.3-1/src/fortran/lapack/dopgtr.f @@ -0,0 +1,160 @@ + SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDQ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IINFO, IJ, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DORG2L, DORG2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DOPGTR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* 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 + DO 20 J = 1, N - 1 + DO 10 I = 1, J - 1 + Q( I, J ) = AP( IJ ) + IJ = IJ + 1 + 10 CONTINUE + IJ = IJ + 2 + Q( N, J ) = ZERO + 20 CONTINUE + DO 30 I = 1, N - 1 + Q( I, N ) = ZERO + 30 CONTINUE + Q( N, N ) = ONE +* +* Generate Q(1:n-1,1:n-1) +* + CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, 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( 1, 1 ) = ONE + DO 40 I = 2, N + Q( I, 1 ) = ZERO + 40 CONTINUE + IJ = 3 + DO 60 J = 2, N + Q( 1, J ) = ZERO + DO 50 I = J + 1, N + Q( I, J ) = AP( IJ ) + IJ = IJ + 1 + 50 CONTINUE + IJ = IJ + 2 + 60 CONTINUE + IF( N.GT.1 ) THEN +* +* Generate Q(2:n,2:n) +* + CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK, + $ IINFO ) + END IF + END IF + RETURN +* +* End of DOPGTR +* + END diff --git a/2.3-1/src/fortran/lapack/dorg2l.f b/2.3-1/src/fortran/lapack/dorg2l.f new file mode 100644 index 00000000..a20965fd --- /dev/null +++ b/2.3-1/src/fortran/lapack/dorg2l.f @@ -0,0 +1,127 @@ + SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, II, J, L +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORG2L', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Initialise columns 1:n-k to columns of the unit matrix +* + DO 20 J = 1, N - K + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( M-N+J, J ) = ONE + 20 CONTINUE +* + DO 40 I = 1, K + II = N - K + I +* +* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left +* + A( M-N+II, II ) = ONE + CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, + $ LDA, WORK ) + CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) + A( M-N+II, II ) = ONE - TAU( I ) +* +* Set A(m-k+i+1:m,n-k+i) to zero +* + DO 30 L = M - N + II + 1, M + A( L, II ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of DORG2L +* + END diff --git a/2.3-1/src/fortran/lapack/dorg2r.f b/2.3-1/src/fortran/lapack/dorg2r.f new file mode 100644 index 00000000..476e9f70 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dorg2r.f @@ -0,0 +1,129 @@ + SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORG2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Initialise columns k+1:n to columns of the unit matrix +* + DO 20 J = K + 1, N + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( J, J ) = ONE + 20 CONTINUE +* + DO 40 I = K, 1, -1 +* +* Apply H(i) to A(i:m,i:n) from the left +* + IF( I.LT.N ) THEN + A( I, I ) = ONE + CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + END IF + IF( I.LT.M ) + $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = ONE - TAU( I ) +* +* Set A(1:i-1,i) to zero +* + DO 30 L = 1, I - 1 + A( L, I ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of DORG2R +* + END diff --git a/2.3-1/src/fortran/lapack/dorgbr.f b/2.3-1/src/fortran/lapack/dorgbr.f new file mode 100644 index 00000000..dc882990 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dorgbr.f @@ -0,0 +1,244 @@ + SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER VECT + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, WANTQ + INTEGER I, IINFO, J, LWKOPT, MN, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DORGLQ, DORGQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + WANTQ = LSAME( VECT, 'Q' ) + MN = MIN( M, N ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M, + $ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT. + $ MIN( N, K ) ) ) ) THEN + INFO = -3 + ELSE IF( K.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( WANTQ ) THEN + NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) + ELSE + NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 ) + END IF + LWKOPT = MAX( 1, MN )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGBR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( WANTQ ) THEN +* +* Form Q, determined by a call to DGEBRD to reduce an m-by-k +* matrix +* + IF( M.GE.K ) THEN +* +* If m >= k, assume m >= n >= k +* + CALL DORGQR( M, N, K, A, LDA, TAU, WORK, 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 +* + DO 20 J = M, 2, -1 + A( 1, J ) = ZERO + DO 10 I = J + 1, M + A( I, J ) = A( I, J-1 ) + 10 CONTINUE + 20 CONTINUE + A( 1, 1 ) = ONE + DO 30 I = 2, M + A( I, 1 ) = ZERO + 30 CONTINUE + IF( M.GT.1 ) THEN +* +* Form Q(2:m,2:m) +* + CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, + $ LWORK, IINFO ) + END IF + END IF + ELSE +* +* Form P', determined by a call to DGEBRD to reduce a k-by-n +* matrix +* + IF( K.LT.N ) THEN +* +* If k < n, assume k <= m <= n +* + CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, 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( 1, 1 ) = ONE + DO 40 I = 2, N + A( I, 1 ) = ZERO + 40 CONTINUE + DO 60 J = 2, N + DO 50 I = J - 1, 2, -1 + A( I, J ) = A( I-1, J ) + 50 CONTINUE + A( 1, J ) = ZERO + 60 CONTINUE + IF( N.GT.1 ) THEN +* +* Form P'(2:n,2:n) +* + CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, + $ LWORK, IINFO ) + END IF + END IF + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORGBR +* + END diff --git a/2.3-1/src/fortran/lapack/dorghr.f b/2.3-1/src/fortran/lapack/dorghr.f new file mode 100644 index 00000000..1283aece --- /dev/null +++ b/2.3-1/src/fortran/lapack/dorghr.f @@ -0,0 +1,164 @@ + SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IINFO, J, LWKOPT, NB, NH +* .. +* .. External Subroutines .. + EXTERNAL DORGQR, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NH = IHI - ILO + LQUERY = ( LWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'DORGQR', ' ', NH, NH, NH, -1 ) + LWKOPT = MAX( 1, NH )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGHR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* 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 +* + DO 40 J = IHI, ILO + 1, -1 + DO 10 I = 1, J - 1 + A( I, J ) = ZERO + 10 CONTINUE + DO 20 I = J + 1, IHI + A( I, J ) = A( I, J-1 ) + 20 CONTINUE + DO 30 I = IHI + 1, N + A( I, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + DO 60 J = 1, ILO + DO 50 I = 1, N + A( I, J ) = ZERO + 50 CONTINUE + A( J, J ) = ONE + 60 CONTINUE + DO 80 J = IHI + 1, N + DO 70 I = 1, N + A( I, J ) = ZERO + 70 CONTINUE + A( J, J ) = ONE + 80 CONTINUE +* + IF( NH.GT.0 ) THEN +* +* Generate Q(ilo+1:ihi,ilo+1:ihi) +* + CALL DORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), + $ WORK, LWORK, IINFO ) + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORGHR +* + END diff --git a/2.3-1/src/fortran/lapack/dorgl2.f b/2.3-1/src/fortran/lapack/dorgl2.f new file mode 100644 index 00000000..1e08344d --- /dev/null +++ b/2.3-1/src/fortran/lapack/dorgl2.f @@ -0,0 +1,133 @@ + SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.M ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGL2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.LE.0 ) + $ RETURN +* + IF( K.LT.M ) THEN +* +* Initialise rows k+1:m to rows of the unit matrix +* + DO 20 J = 1, N + DO 10 L = K + 1, M + A( L, J ) = ZERO + 10 CONTINUE + IF( J.GT.K .AND. J.LE.M ) + $ A( J, J ) = ONE + 20 CONTINUE + END IF +* + DO 40 I = K, 1, -1 +* +* Apply H(i) to A(i:m,i:n) from the right +* + IF( I.LT.N ) THEN + IF( I.LT.M ) THEN + A( I, I ) = ONE + CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAU( I ), A( I+1, I ), LDA, WORK ) + END IF + CALL DSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) + END IF + A( I, I ) = ONE - TAU( I ) +* +* Set A(i,1:i-1) to zero +* + DO 30 L = 1, I - 1 + A( I, L ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of DORGL2 +* + END diff --git a/2.3-1/src/fortran/lapack/dorglq.f b/2.3-1/src/fortran/lapack/dorglq.f new file mode 100644 index 00000000..e4f58c96 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dorglq.f @@ -0,0 +1,215 @@ + SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, + $ LWKOPT, NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORGL2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 ) + LWKOPT = MAX( 1, M )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.M ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGLQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.LE.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = M + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DORGLQ', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = M + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORGLQ', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code after the last block. +* The first kk rows are handled by the block method. +* + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) +* +* Set A(kk+1:m,1:kk) to zero. +* + DO 20 J = 1, KK + DO 10 I = KK + 1, M + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* Use unblocked code for the last or only block. +* + IF( KK.LT.M ) + $ CALL DORGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, + $ TAU( KK+1 ), WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* Use blocked code +* + DO 50 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF( I+IB.LE.M ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), + $ LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H' to A(i+ib:m,i:n) from the right +* + CALL DLARFB( 'Right', 'Transpose', 'Forward', 'Rowwise', + $ M-I-IB+1, N-I+1, IB, A( I, I ), LDA, WORK, + $ LDWORK, A( I+IB, I ), LDA, WORK( IB+1 ), + $ LDWORK ) + END IF +* +* Apply H' to columns i:n of current block +* + CALL DORGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* +* Set columns 1:i-1 of current block to zero +* + DO 40 J = 1, I - 1 + DO 30 L = I, I + IB - 1 + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of DORGLQ +* + END diff --git a/2.3-1/src/fortran/lapack/dorgql.f b/2.3-1/src/fortran/lapack/dorgql.f new file mode 100644 index 00000000..1c4896e9 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dorgql.f @@ -0,0 +1,222 @@ + SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, + $ NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) + LWKOPT = N*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGQL', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code after the first block. +* The last kk columns are handled by the block method. +* + KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) +* +* Set A(m-kk+1:m,1:n-kk) to zero. +* + DO 20 J = 1, N - KK + DO 10 I = M - KK + 1, M + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* Use unblocked code for the first or only block. +* + CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* Use blocked code +* + DO 50 I = K - KK + 1, K, NB + IB = MIN( NB, K-I+1 ) + IF( N-K+I.GT.1 ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i+ib-1) . . . H(i+1) H(i) +* + CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, + $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left +* + CALL DLARFB( 'Left', 'No transpose', 'Backward', + $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, + $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, + $ WORK( IB+1 ), LDWORK ) + END IF +* +* Apply H to rows 1:m-k+i+ib-1 of current block +* + CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, + $ TAU( I ), WORK, IINFO ) +* +* Set rows m-k+i+ib:m of current block to zero +* + DO 40 J = N - K + I, N - K + I + IB - 1 + DO 30 L = M - K + I + IB, M + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of DORGQL +* + END diff --git a/2.3-1/src/fortran/lapack/dorgqr.f b/2.3-1/src/fortran/lapack/dorgqr.f new file mode 100644 index 00000000..4db0ef5a --- /dev/null +++ b/2.3-1/src/fortran/lapack/dorgqr.f @@ -0,0 +1,216 @@ + SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, + $ LWKOPT, NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) + LWKOPT = MAX( 1, N )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code after the last block. +* The first kk columns are handled by the block method. +* + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) +* +* Set A(1:kk,kk+1:n) to zero. +* + DO 20 J = KK + 1, N + DO 10 I = 1, KK + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* Use unblocked code for the last or only block. +* + IF( KK.LT.N ) + $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, + $ TAU( KK+1 ), WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* Use blocked code +* + DO 50 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF( I+IB.LE.N ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, + $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(i:m,i+ib:n) from the left +* + CALL DLARFB( 'Left', 'No transpose', 'Forward', + $ 'Columnwise', M-I+1, N-I-IB+1, IB, + $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), + $ LDA, WORK( IB+1 ), LDWORK ) + END IF +* +* Apply H to rows i:m of current block +* + CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* +* Set rows 1:i-1 of current block to zero +* + DO 40 J = I, I + IB - 1 + DO 30 L = 1, I - 1 + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of DORGQR +* + END diff --git a/2.3-1/src/fortran/lapack/dorgr2.f b/2.3-1/src/fortran/lapack/dorgr2.f new file mode 100644 index 00000000..9da45c5f --- /dev/null +++ b/2.3-1/src/fortran/lapack/dorgr2.f @@ -0,0 +1,131 @@ + SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, II, J, L +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.M ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGR2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.LE.0 ) + $ RETURN +* + IF( K.LT.M ) THEN +* +* Initialise rows 1:m-k to rows of the unit matrix +* + DO 20 J = 1, N + DO 10 L = 1, M - K + A( L, J ) = ZERO + 10 CONTINUE + IF( J.GT.N-M .AND. J.LE.N-K ) + $ A( M-N+J, J ) = ONE + 20 CONTINUE + END IF +* + DO 40 I = 1, K + II = M - K + I +* +* Apply H(i) to A(1:m-k+i,1:n-k+i) from the right +* + A( II, N-M+II ) = ONE + CALL DLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, TAU( I ), + $ A, LDA, WORK ) + CALL DSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA ) + A( II, N-M+II ) = ONE - TAU( I ) +* +* Set A(m-k+i,n-k+i+1:n) to zero +* + DO 30 L = N - M + II + 1, N + A( II, L ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of DORGR2 +* + END diff --git a/2.3-1/src/fortran/lapack/dorgrq.f b/2.3-1/src/fortran/lapack/dorgrq.f new file mode 100644 index 00000000..11633403 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dorgrq.f @@ -0,0 +1,222 @@ + SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, II, IINFO, IWS, J, KK, L, LDWORK, + $ LWKOPT, NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORGR2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.M ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( M.LE.0 ) THEN + LWKOPT = 1 + ELSE + NB = ILAENV( 1, 'DORGRQ', ' ', M, N, K, -1 ) + LWKOPT = M*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGRQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.LE.0 ) THEN + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = M + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DORGRQ', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = M + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORGRQ', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code after the first block. +* The last kk rows are handled by the block method. +* + KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) +* +* Set A(1:m-kk,n-kk+1:n) to zero. +* + DO 20 J = N - KK + 1, N + DO 10 I = 1, M - KK + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* Use unblocked code for the first or only block. +* + CALL DORGR2( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* Use blocked code +* + DO 50 I = K - KK + 1, K, NB + IB = MIN( NB, K-I+1 ) + II = M - K + I + IF( II.GT.1 ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i+ib-1) . . . H(i+1) H(i) +* + CALL DLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB, + $ A( II, 1 ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H' to A(1:m-k+i-1,1:n-k+i+ib-1) from the right +* + CALL DLARFB( 'Right', 'Transpose', 'Backward', 'Rowwise', + $ II-1, N-K+I+IB-1, IB, A( II, 1 ), LDA, WORK, + $ LDWORK, A, LDA, WORK( IB+1 ), LDWORK ) + END IF +* +* Apply H' to columns 1:n-k+i+ib-1 of current block +* + CALL DORGR2( IB, N-K+I+IB-1, IB, A( II, 1 ), LDA, TAU( I ), + $ WORK, IINFO ) +* +* Set columns n-k+i+ib:n of current block to zero +* + DO 40 L = N - K + I + IB, N + DO 30 J = II, II + IB - 1 + A( J, L ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of DORGRQ +* + END diff --git a/2.3-1/src/fortran/lapack/dorgtr.f b/2.3-1/src/fortran/lapack/dorgtr.f new file mode 100644 index 00000000..4c72d031 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dorgtr.f @@ -0,0 +1,183 @@ + SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, J, LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DORGQL, DORGQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( UPPER ) THEN + NB = ILAENV( 1, 'DORGQL', ' ', N-1, N-1, N-1, -1 ) + ELSE + NB = ILAENV( 1, 'DORGQR', ' ', N-1, N-1, N-1, -1 ) + END IF + LWKOPT = MAX( 1, N-1 )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGTR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( UPPER ) THEN +* +* 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 +* + DO 20 J = 1, N - 1 + DO 10 I = 1, J - 1 + A( I, J ) = A( I, J+1 ) + 10 CONTINUE + A( N, J ) = ZERO + 20 CONTINUE + DO 30 I = 1, N - 1 + A( I, N ) = ZERO + 30 CONTINUE + A( N, N ) = ONE +* +* Generate Q(1:n-1,1:n-1) +* + CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, 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 +* + DO 50 J = N, 2, -1 + A( 1, J ) = ZERO + DO 40 I = J + 1, N + A( I, J ) = A( I, J-1 ) + 40 CONTINUE + 50 CONTINUE + A( 1, 1 ) = ONE + DO 60 I = 2, N + A( I, 1 ) = ZERO + 60 CONTINUE + IF( N.GT.1 ) THEN +* +* Generate Q(2:n,2:n) +* + CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, + $ LWORK, IINFO ) + END IF + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORGTR +* + END diff --git a/2.3-1/src/fortran/lapack/dorm2l.f b/2.3-1/src/fortran/lapack/dorm2l.f new file mode 100644 index 00000000..27120075 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dorm2l.f @@ -0,0 +1,193 @@ + SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, MI, NI, NQ + DOUBLE PRECISION AII +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORM2L', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) + $ THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + ELSE + MI = M + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) is applied to C(1:m-k+i,1:n) +* + MI = M - K + I + ELSE +* +* H(i) is applied to C(1:m,1:n-k+i) +* + NI = N - K + I + END IF +* +* Apply H(i) +* + AII = A( NQ-K+I, I ) + A( NQ-K+I, I ) = ONE + CALL DLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC, + $ WORK ) + A( NQ-K+I, I ) = AII + 10 CONTINUE + RETURN +* +* End of DORM2L +* + END diff --git a/2.3-1/src/fortran/lapack/dorm2r.f b/2.3-1/src/fortran/lapack/dorm2r.f new file mode 100644 index 00000000..79c9ef35 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dorm2r.f @@ -0,0 +1,197 @@ + SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + DOUBLE PRECISION AII +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORM2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) + $ THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), + $ LDC, WORK ) + A( I, I ) = AII + 10 CONTINUE + RETURN +* +* End of DORM2R +* + END diff --git a/2.3-1/src/fortran/lapack/dormbr.f b/2.3-1/src/fortran/lapack/dormbr.f new file mode 100644 index 00000000..8066b893 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dormbr.f @@ -0,0 +1,281 @@ + SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, + $ LDC, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS, VECT + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN + CHARACTER TRANST + INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DORMLQ, DORMQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + APPLYQ = LSAME( VECT, 'Q' ) + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q or P and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( K.LT.0 ) THEN + INFO = -6 + ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. + $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) + $ THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( APPLYQ ) THEN + IF( LEFT ) THEN + NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, + $ -1 ) + ELSE + NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, + $ -1 ) + END IF + ELSE + IF( LEFT ) THEN + NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M-1, N, M-1, + $ -1 ) + ELSE + NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N-1, N-1, + $ -1 ) + END IF + END IF + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMBR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + WORK( 1 ) = 1 + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* + IF( APPLYQ ) THEN +* +* Apply Q +* + IF( NQ.GE.K ) THEN +* +* Q was determined by a call to DGEBRD with nq >= k +* + CALL DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, IINFO ) + ELSE IF( NQ.GT.1 ) THEN +* +* Q was determined by a call to DGEBRD with nq < k +* + IF( LEFT ) THEN + MI = M - 1 + NI = N + I1 = 2 + I2 = 1 + ELSE + MI = M + NI = N - 1 + I1 = 1 + I2 = 2 + END IF + CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, + $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) + END IF + ELSE +* +* Apply P +* + IF( NOTRAN ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF + IF( NQ.GT.K ) THEN +* +* P was determined by a call to DGEBRD with nq > k +* + CALL DORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, IINFO ) + ELSE IF( NQ.GT.1 ) THEN +* +* P was determined by a call to DGEBRD with nq <= k +* + IF( LEFT ) THEN + MI = M - 1 + NI = N + I1 = 2 + I2 = 1 + ELSE + MI = M + NI = N - 1 + I1 = 1 + I2 = 2 + END IF + CALL DORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, + $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) + END IF + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMBR +* + END diff --git a/2.3-1/src/fortran/lapack/dormhr.f b/2.3-1/src/fortran/lapack/dormhr.f new file mode 100644 index 00000000..5862538e --- /dev/null +++ b/2.3-1/src/fortran/lapack/dormhr.f @@ -0,0 +1,201 @@ + SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, + $ LDC, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + LOGICAL LEFT, LQUERY + INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DORMQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NH = IHI - ILO + LEFT = LSAME( SIDE, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) + $ THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN + INFO = -5 + ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( LEFT ) THEN + NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, NH, N, NH, -1 ) + ELSE + NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, NH, NH, -1 ) + END IF + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMHR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( LEFT ) THEN + MI = NH + NI = N + I1 = ILO + 1 + I2 = 1 + ELSE + MI = M + NI = NH + I1 = 1 + I2 = ILO + 1 + END IF +* + CALL DORMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA, + $ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO ) +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMHR +* + END diff --git a/2.3-1/src/fortran/lapack/dorml2.f b/2.3-1/src/fortran/lapack/dorml2.f new file mode 100644 index 00000000..d3941c9a --- /dev/null +++ b/2.3-1/src/fortran/lapack/dorml2.f @@ -0,0 +1,197 @@ + SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + DOUBLE PRECISION AII +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORML2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) + $ THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ), + $ C( IC, JC ), LDC, WORK ) + A( I, I ) = AII + 10 CONTINUE + RETURN +* +* End of DORML2 +* + END diff --git a/2.3-1/src/fortran/lapack/dormlq.f b/2.3-1/src/fortran/lapack/dormlq.f new file mode 100644 index 00000000..f0c68ef2 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dormlq.f @@ -0,0 +1,267 @@ + SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + CHARACTER TRANST + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + DOUBLE PRECISION T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORML2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. NB may be at most NBMAX, where NBMAX +* is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMLQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + IF( NOTRAN ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), + $ LDA, TAU( I ), T, LDT ) + IF( LEFT ) THEN +* +* 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 + END IF +* +* Apply H or H' +* + CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, + $ A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, WORK, + $ LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMLQ +* + END diff --git a/2.3-1/src/fortran/lapack/dormql.f b/2.3-1/src/fortran/lapack/dormql.f new file mode 100644 index 00000000..f3370f10 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dormql.f @@ -0,0 +1,261 @@ + SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT, + $ MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + DOUBLE PRECISION T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORM2L, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = MAX( 1, N ) + ELSE + NQ = N + NW = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + LWKOPT = 1 + ELSE +* +* Determine the block size. NB may be at most NBMAX, where +* NBMAX is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N, + $ K, -1 ) ) + LWKOPT = NW*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMQL', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMQL', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + ELSE + MI = M + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i+ib-1) . . . H(i+1) H(i) +* + CALL DLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB, + $ A( 1, I ), LDA, TAU( I ), T, LDT ) + IF( LEFT ) THEN +* +* 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 + END IF +* +* Apply H or H' +* + CALL DLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI, + $ IB, A( 1, I ), LDA, T, LDT, C, LDC, WORK, + $ LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMQL +* + END diff --git a/2.3-1/src/fortran/lapack/dormqr.f b/2.3-1/src/fortran/lapack/dormqr.f new file mode 100644 index 00000000..ee372695 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dormqr.f @@ -0,0 +1,260 @@ + SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + DOUBLE PRECISION T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. NB may be at most NBMAX, where NBMAX +* is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), + $ LDA, TAU( I ), T, LDT ) + IF( LEFT ) THEN +* +* 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 + END IF +* +* Apply H or H' +* + CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, + $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, + $ WORK, LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMQR +* + END diff --git a/2.3-1/src/fortran/lapack/dormr2.f b/2.3-1/src/fortran/lapack/dormr2.f new file mode 100644 index 00000000..994552fb --- /dev/null +++ b/2.3-1/src/fortran/lapack/dormr2.f @@ -0,0 +1,193 @@ + SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, MI, NI, NQ + DOUBLE PRECISION AII +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMR2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) + $ THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + ELSE + MI = M + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) is applied to C(1:m-k+i,1:n) +* + MI = M - K + I + ELSE +* +* H(i) is applied to C(1:m,1:n-k+i) +* + NI = N - K + I + END IF +* +* Apply H(i) +* + AII = A( I, NQ-K+I ) + A( I, NQ-K+I ) = ONE + CALL DLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, LDC, + $ WORK ) + A( I, NQ-K+I ) = AII + 10 CONTINUE + RETURN +* +* End of DORMR2 +* + END diff --git a/2.3-1/src/fortran/lapack/dormr3.f b/2.3-1/src/fortran/lapack/dormr3.f new file mode 100644 index 00000000..7bdcb856 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dormr3.f @@ -0,0 +1,206 @@ + SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, L, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARZ, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR. + $ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMR3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JA = M - L + 1 + JC = 1 + ELSE + MI = M + JA = N - L + 1 + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* 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 + END IF +* +* Apply H(i) or H(i)' +* + CALL DLARZ( SIDE, MI, NI, L, A( I, JA ), LDA, TAU( I ), + $ C( IC, JC ), LDC, WORK ) +* + 10 CONTINUE +* + RETURN +* +* End of DORMR3 +* + END diff --git a/2.3-1/src/fortran/lapack/dormrq.f b/2.3-1/src/fortran/lapack/dormrq.f new file mode 100644 index 00000000..522c1392 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dormrq.f @@ -0,0 +1,268 @@ + SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + CHARACTER TRANST + INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT, + $ MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + DOUBLE PRECISION T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORMR2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = MAX( 1, N ) + ELSE + NQ = N + NW = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + LWKOPT = 1 + ELSE +* +* Determine the block size. NB may be at most NBMAX, where +* NBMAX is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMRQ', SIDE // TRANS, M, N, + $ K, -1 ) ) + LWKOPT = NW*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMRQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMRQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + ELSE + MI = M + END IF +* + IF( NOTRAN ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i+ib-1) . . . H(i+1) H(i) +* + CALL DLARFT( 'Backward', 'Rowwise', NQ-K+I+IB-1, IB, + $ A( I, 1 ), LDA, TAU( I ), T, LDT ) + IF( LEFT ) THEN +* +* 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 + END IF +* +* Apply H or H' +* + CALL DLARFB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI, + $ IB, A( I, 1 ), LDA, T, LDT, C, LDC, WORK, + $ LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMRQ +* + END diff --git a/2.3-1/src/fortran/lapack/dormrz.f b/2.3-1/src/fortran/lapack/dormrz.f new file mode 100644 index 00000000..9e14acce --- /dev/null +++ b/2.3-1/src/fortran/lapack/dormrz.f @@ -0,0 +1,292 @@ + SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, L, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + CHARACTER TRANST + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JA, JC, + $ LDWORK, LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + DOUBLE PRECISION T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLARZB, DLARZT, DORMR3, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = MAX( 1, N ) + ELSE + NQ = N + NW = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR. + $ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + LWKOPT = 1 +* +* Determine the block size. NB may be at most NBMAX, where +* NBMAX is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMRQ', SIDE // TRANS, M, N, + $ K, -1 ) ) + LWKOPT = NW*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMRZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMRQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, + $ WORK, IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + JA = M - L + 1 + ELSE + MI = M + IC = 1 + JA = N - L + 1 + END IF +* + IF( NOTRAN ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i+ib-1) . . . H(i+1) H(i) +* + CALL DLARZT( 'Backward', 'Rowwise', L, IB, A( I, JA ), LDA, + $ TAU( I ), T, LDT ) +* + IF( LEFT ) THEN +* +* 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 + END IF +* +* Apply H or H' +* + CALL DLARZB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI, + $ IB, L, A( I, JA ), LDA, T, LDT, C( IC, JC ), + $ LDC, WORK, LDWORK ) + 10 CONTINUE +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DORMRZ +* + END diff --git a/2.3-1/src/fortran/lapack/dpocon.f b/2.3-1/src/fortran/lapack/dpocon.f new file mode 100644 index 00000000..c28af374 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dpocon.f @@ -0,0 +1,177 @@ + SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, + $ INFO ) +* +* -- LAPACK routine (version 3.1) -- +* 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + CHARACTER NORMIN + INTEGER IX, KASE + DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IDAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPOCON', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.EQ.ZERO ) THEN + RETURN + END IF +* + SMLNUM = DLAMCH( 'Safe minimum' ) +* +* Estimate the 1-norm of inv(A). +* + KASE = 0 + NORMIN = 'N' + 10 CONTINUE + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( UPPER ) THEN +* +* Multiply by inv(U'). +* + CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A, + $ LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO ) + NORMIN = 'Y' +* +* Multiply by inv(U). +* + CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, + $ A, LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO ) + ELSE +* +* Multiply by inv(L). +* + CALL DLATRS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N, + $ A, LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO ) + NORMIN = 'Y' +* +* Multiply by inv(L'). +* + CALL DLATRS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N, A, + $ LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO ) + END IF +* +* Multiply by 1/SCALE if doing so will not cause overflow. +* + SCALE = SCALEL*SCALEU + IF( SCALE.NE.ONE ) THEN + IX = IDAMAX( N, WORK, 1 ) + IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) + $ GO TO 20 + CALL DRSCL( N, SCALE, WORK, 1 ) + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + 20 CONTINUE + RETURN +* +* End of DPOCON +* + END diff --git a/2.3-1/src/fortran/lapack/dpotf2.f b/2.3-1/src/fortran/lapack/dpotf2.f new file mode 100644 index 00000000..b7d65e91 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dpotf2.f @@ -0,0 +1,167 @@ + SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J + DOUBLE PRECISION AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPOTF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization A = U'*U. +* + DO 10 J = 1, N +* +* Compute U(J,J) and test for non-positive-definiteness. +* + AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 ) + IF( AJJ.LE.ZERO ) THEN + A( J, J ) = AJJ + GO TO 30 + END IF + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of row J. +* + IF( J.LT.N ) THEN + CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ), + $ LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA ) + CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) + END IF + 10 CONTINUE + ELSE +* +* Compute the Cholesky factorization A = L*L'. +* + DO 20 J = 1, N +* +* Compute L(J,J) and test for non-positive-definiteness. +* + AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ), + $ LDA ) + IF( AJJ.LE.ZERO ) THEN + A( J, J ) = AJJ + GO TO 30 + END IF + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of column J. +* + IF( J.LT.N ) THEN + CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ), + $ LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 ) + CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) + END IF + 20 CONTINUE + END IF + GO TO 40 +* + 30 CONTINUE + INFO = J +* + 40 CONTINUE + RETURN +* +* End of DPOTF2 +* + END diff --git a/2.3-1/src/fortran/lapack/dpotrf.f b/2.3-1/src/fortran/lapack/dpotrf.f new file mode 100644 index 00000000..8449df6d --- /dev/null +++ b/2.3-1/src/fortran/lapack/dpotrf.f @@ -0,0 +1,183 @@ + SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, JB, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DPOTF2, DSYRK, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPOTRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code. +* + CALL DPOTF2( UPLO, N, A, LDA, INFO ) + ELSE +* +* Use blocked code. +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization A = U'*U. +* + DO 10 J = 1, N, NB +* +* Update and factorize the current diagonal block and test +* for non-positive-definiteness. +* + JB = MIN( NB, N-J+1 ) + CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, + $ A( 1, J ), LDA, ONE, A( J, J ), LDA ) + CALL DPOTF2( 'Upper', JB, A( J, J ), LDA, INFO ) + IF( INFO.NE.0 ) + $ GO TO 30 + IF( J+JB.LE.N ) THEN +* +* Compute the current block row. +* + CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1, + $ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ), + $ LDA, ONE, A( J, J+JB ), LDA ) + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', + $ JB, N-J-JB+1, ONE, A( J, J ), LDA, + $ A( J, J+JB ), LDA ) + END IF + 10 CONTINUE +* + ELSE +* +* Compute the Cholesky factorization A = L*L'. +* + DO 20 J = 1, N, NB +* +* Update and factorize the current diagonal block and test +* for non-positive-definiteness. +* + JB = MIN( NB, N-J+1 ) + CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE, + $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) + CALL DPOTF2( 'Lower', JB, A( J, J ), LDA, INFO ) + IF( INFO.NE.0 ) + $ GO TO 30 + IF( J+JB.LE.N ) THEN +* +* Compute the current block column. +* + CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ), + $ LDA, ONE, A( J+JB, J ), LDA ) + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit', + $ N-J-JB+1, JB, ONE, A( J, J ), LDA, + $ A( J+JB, J ), LDA ) + END IF + 20 CONTINUE + END IF + END IF + GO TO 40 +* + 30 CONTINUE + INFO = INFO + J - 1 +* + 40 CONTINUE + RETURN +* +* End of DPOTRF +* + END diff --git a/2.3-1/src/fortran/lapack/dpotrs.f b/2.3-1/src/fortran/lapack/dpotrs.f new file mode 100644 index 00000000..0273655e --- /dev/null +++ b/2.3-1/src/fortran/lapack/dpotrs.f @@ -0,0 +1,132 @@ + SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPOTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B where A = U'*U. +* +* Solve U'*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve U*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, A, LDA, B, LDB ) + ELSE +* +* Solve A*X = B where A = L*L'. +* +* Solve L*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, A, LDA, B, LDB ) +* +* Solve L'*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) + END IF +* + RETURN +* +* End of DPOTRS +* + END diff --git a/2.3-1/src/fortran/lapack/dpptrf.f b/2.3-1/src/fortran/lapack/dpptrf.f new file mode 100644 index 00000000..a5e2a596 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dpptrf.f @@ -0,0 +1,177 @@ + SUBROUTINE DPPTRF( UPLO, N, AP, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, JC, JJ + DOUBLE PRECISION AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSPR, DTPSV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPPTRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization A = U'*U. +* + JJ = 0 + DO 10 J = 1, N + JC = JJ + 1 + JJ = JJ + J +* +* Compute elements 1:J-1 of column J. +* + IF( J.GT.1 ) + $ CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', J-1, AP, + $ AP( JC ), 1 ) +* +* Compute U(J,J) and test for non-positive-definiteness. +* + AJJ = AP( JJ ) - DDOT( J-1, AP( JC ), 1, AP( JC ), 1 ) + IF( AJJ.LE.ZERO ) THEN + AP( JJ ) = AJJ + GO TO 30 + END IF + AP( JJ ) = SQRT( AJJ ) + 10 CONTINUE + ELSE +* +* Compute the Cholesky factorization A = L*L'. +* + JJ = 1 + DO 20 J = 1, N +* +* Compute L(J,J) and test for non-positive-definiteness. +* + AJJ = AP( JJ ) + IF( AJJ.LE.ZERO ) THEN + AP( JJ ) = AJJ + GO TO 30 + END IF + AJJ = SQRT( AJJ ) + AP( JJ ) = AJJ +* +* Compute elements J+1:N of column J and update the trailing +* submatrix. +* + IF( J.LT.N ) THEN + CALL DSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 ) + CALL DSPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1, + $ AP( JJ+N-J+1 ) ) + JJ = JJ + N - J + 1 + END IF + 20 CONTINUE + END IF + GO TO 40 +* + 30 CONTINUE + INFO = J +* + 40 CONTINUE + RETURN +* +* End of DPPTRF +* + END diff --git a/2.3-1/src/fortran/lapack/drscl.f b/2.3-1/src/fortran/lapack/drscl.f new file mode 100644 index 00000000..a13e96d8 --- /dev/null +++ b/2.3-1/src/fortran/lapack/drscl.f @@ -0,0 +1,114 @@ + SUBROUTINE DRSCL( N, SA, SX, INCX ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION SA +* .. +* .. Array Arguments .. + DOUBLE PRECISION SX( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + DOUBLE PRECISION BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Get machine parameters +* + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* +* Initialize the denominator to SA and the numerator to 1. +* + CDEN = SA + CNUM = ONE +* + 10 CONTINUE + CDEN1 = CDEN*SMLNUM + CNUM1 = CNUM / BIGNUM + IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN +* +* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. +* + MUL = SMLNUM + DONE = .FALSE. + CDEN = CDEN1 + ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN +* +* 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. + END IF +* +* Scale the vector X by MUL +* + CALL DSCAL( N, MUL, SX, INCX ) +* + IF( .NOT.DONE ) + $ GO TO 10 +* + RETURN +* +* End of DRSCL +* + END diff --git a/2.3-1/src/fortran/lapack/dspev.f b/2.3-1/src/fortran/lapack/dspev.f new file mode 100644 index 00000000..64582c99 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dspev.f @@ -0,0 +1,187 @@ + SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL WANTZ + INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSP + EXTERNAL LSAME, DLAMCH, DLANSP +* .. +* .. External Subroutines .. + EXTERNAL DOPGTR, DSCAL, DSPTRD, DSTEQR, DSTERF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) + $ THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -7 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPEV ', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + W( 1 ) = AP( 1 ) + IF( WANTZ ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = DLANSP( 'M', UPLO, N, AP, WORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) + END IF +* +* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. +* + INDE = 1 + INDTAU = INDE + N + CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, first call +* DOPGTR to generate the orthogonal matrix, then call DSTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE + INDWRK = INDTAU + N + CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ, + $ WORK( INDWRK ), IINFO ) + CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDTAU ), + $ INFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* + RETURN +* +* End of DSPEV +* + END diff --git a/2.3-1/src/fortran/lapack/dspgst.f b/2.3-1/src/fortran/lapack/dspgst.f new file mode 100644 index 00000000..8e121a94 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dspgst.f @@ -0,0 +1,208 @@ + SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, ITYPE, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), BP( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, HALF + PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, J1, J1J1, JJ, K, K1, K1K1, KK + DOUBLE PRECISION AJJ, AKK, BJJ, BKK, CT +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DSCAL, DSPMV, DSPR2, DTPMV, DTPSV, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPGST', -INFO ) + RETURN + END IF +* + IF( ITYPE.EQ.1 ) THEN + IF( UPPER ) THEN +* +* Compute inv(U')*A*inv(U) +* +* J1 and JJ are the indices of A(1,j) and A(j,j) +* + JJ = 0 + DO 10 J = 1, N + J1 = JJ + 1 + JJ = JJ + J +* +* Compute the j-th column of the upper triangle of A +* + BJJ = BP( JJ ) + CALL DTPSV( UPLO, 'Transpose', 'Nonunit', J, BP, + $ AP( J1 ), 1 ) + CALL DSPMV( UPLO, J-1, -ONE, AP, BP( J1 ), 1, ONE, + $ AP( J1 ), 1 ) + CALL DSCAL( J-1, ONE / BJJ, AP( J1 ), 1 ) + AP( JJ ) = ( AP( JJ )-DDOT( J-1, AP( J1 ), 1, BP( J1 ), + $ 1 ) ) / BJJ + 10 CONTINUE + 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 + DO 20 K = 1, N + K1K1 = KK + N - K + 1 +* +* Update the lower triangle of A(k:n,k:n) +* + AKK = AP( KK ) + BKK = BP( KK ) + AKK = AKK / BKK**2 + AP( KK ) = AKK + IF( K.LT.N ) THEN + CALL DSCAL( N-K, ONE / BKK, AP( KK+1 ), 1 ) + CT = -HALF*AKK + CALL DAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 ) + CALL DSPR2( UPLO, N-K, -ONE, AP( KK+1 ), 1, + $ BP( KK+1 ), 1, AP( K1K1 ) ) + CALL DAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 ) + CALL DTPSV( UPLO, 'No transpose', 'Non-unit', N-K, + $ BP( K1K1 ), AP( KK+1 ), 1 ) + END IF + KK = K1K1 + 20 CONTINUE + END IF + ELSE + IF( UPPER ) THEN +* +* Compute U*A*U' +* +* K1 and KK are the indices of A(1,k) and A(k,k) +* + KK = 0 + DO 30 K = 1, N + K1 = KK + 1 + KK = KK + K +* +* Update the upper triangle of A(1:k,1:k) +* + AKK = AP( KK ) + BKK = BP( KK ) + CALL DTPMV( UPLO, 'No transpose', 'Non-unit', K-1, BP, + $ AP( K1 ), 1 ) + CT = HALF*AKK + CALL DAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 ) + CALL DSPR2( UPLO, K-1, ONE, AP( K1 ), 1, BP( K1 ), 1, + $ AP ) + CALL DAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 ) + CALL DSCAL( K-1, BKK, AP( K1 ), 1 ) + AP( KK ) = AKK*BKK**2 + 30 CONTINUE + ELSE +* +* Compute L'*A*L +* +* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) +* + JJ = 1 + DO 40 J = 1, N + J1J1 = JJ + N - J + 1 +* +* Compute the j-th column of the lower triangle of A +* + AJJ = AP( JJ ) + BJJ = BP( JJ ) + AP( JJ ) = AJJ*BJJ + DDOT( N-J, AP( JJ+1 ), 1, + $ BP( JJ+1 ), 1 ) + CALL DSCAL( N-J, BJJ, AP( JJ+1 ), 1 ) + CALL DSPMV( UPLO, N-J, ONE, AP( J1J1 ), BP( JJ+1 ), 1, + $ ONE, AP( JJ+1 ), 1 ) + CALL DTPMV( UPLO, 'Transpose', 'Non-unit', N-J+1, + $ BP( JJ ), AP( JJ ), 1 ) + JJ = J1J1 + 40 CONTINUE + END IF + END IF + RETURN +* +* End of DSPGST +* + END diff --git a/2.3-1/src/fortran/lapack/dspgv.f b/2.3-1/src/fortran/lapack/dspgv.f new file mode 100644 index 00000000..737a1ee3 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dspgv.f @@ -0,0 +1,195 @@ + SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, + $ INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, ITYPE, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* 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 .. + LOGICAL UPPER, WANTZ + CHARACTER TRANS + INTEGER J, NEIG +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DPPTRF, DSPEV, DSPGST, DTPMV, DTPSV, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + UPPER = LSAME( UPLO, 'U' ) +* + INFO = 0 + IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN + INFO = -1 + ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPGV ', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Form a Cholesky factorization of B. +* + CALL DPPTRF( UPLO, N, BP, INFO ) + IF( INFO.NE.0 ) THEN + INFO = N + INFO + RETURN + END IF +* +* Transform problem to standard eigenvalue problem and solve. +* + CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO ) + CALL DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) +* + IF( WANTZ ) THEN +* +* Backtransform eigenvectors to the original problem. +* + NEIG = N + IF( INFO.GT.0 ) + $ NEIG = INFO - 1 + IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN +* +* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; +* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y +* + IF( UPPER ) THEN + TRANS = 'N' + ELSE + TRANS = 'T' + END IF +* + DO 10 J = 1, NEIG + CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), + $ 1 ) + 10 CONTINUE +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* For B*A*x=(lambda)*x; +* backtransform eigenvectors: x = L*y or U'*y +* + IF( UPPER ) THEN + TRANS = 'T' + ELSE + TRANS = 'N' + END IF +* + DO 20 J = 1, NEIG + CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), + $ 1 ) + 20 CONTINUE + END IF + END IF + RETURN +* +* End of DSPGV +* + END diff --git a/2.3-1/src/fortran/lapack/dsptrd.f b/2.3-1/src/fortran/lapack/dsptrd.f new file mode 100644 index 00000000..6d3390e3 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dsptrd.f @@ -0,0 +1,228 @@ + SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO, HALF + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, + $ HALF = 1.0D0 / 2.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, I1, I1I1, II + DOUBLE PRECISION ALPHA, TAUI +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DLARFG, DSPMV, DSPR2, XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPTRD', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Reduce the upper triangle of A. +* I1 is the index in AP of A(1,I+1). +* + I1 = N*( N-1 ) / 2 + 1 + DO 10 I = N - 1, 1, -1 +* +* Generate elementary reflector H(i) = I - tau * v * v' +* to annihilate A(1:i-1,i+1) +* + CALL DLARFG( I, AP( I1+I-1 ), AP( I1 ), 1, TAUI ) + E( I ) = AP( I1+I-1 ) +* + IF( TAUI.NE.ZERO ) THEN +* +* Apply H(i) from both sides to A(1:i,1:i) +* + AP( I1+I-1 ) = ONE +* +* Compute y := tau * A * v storing y in TAU(1:i) +* + CALL DSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU, + $ 1 ) +* +* Compute w := y - 1/2 * tau * (y'*v) * v +* + ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, AP( I1 ), 1 ) + CALL DAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 ) +* +* Apply the transformation as a rank-2 update: +* A := A - v * w' - w * v' +* + CALL DSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP ) +* + AP( I1+I-1 ) = E( I ) + END IF + D( I+1 ) = AP( I1+I ) + TAU( I ) = TAUI + I1 = I1 - I + 10 CONTINUE + 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 + DO 20 I = 1, N - 1 + I1I1 = II + N - I + 1 +* +* Generate elementary reflector H(i) = I - tau * v * v' +* to annihilate A(i+2:n,i) +* + CALL DLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI ) + E( I ) = AP( II+1 ) +* + IF( TAUI.NE.ZERO ) THEN +* +* Apply H(i) from both sides to A(i+1:n,i+1:n) +* + AP( II+1 ) = ONE +* +* Compute y := tau * A * v storing y in TAU(i:n-1) +* + CALL DSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1, + $ ZERO, TAU( I ), 1 ) +* +* Compute w := y - 1/2 * tau * (y'*v) * v +* + ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, AP( II+1 ), + $ 1 ) + CALL DAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 ) +* +* Apply the transformation as a rank-2 update: +* A := A - v * w' - w * v' +* + CALL DSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1, + $ AP( I1I1 ) ) +* + AP( II+1 ) = E( I ) + END IF + D( I ) = AP( II ) + TAU( I ) = TAUI + II = I1I1 + 20 CONTINUE + D( N ) = AP( II ) + END IF +* + RETURN +* +* End of DSPTRD +* + END diff --git a/2.3-1/src/fortran/lapack/dsptrf.f b/2.3-1/src/fortran/lapack/dsptrf.f new file mode 100644 index 00000000..8b8a9185 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dsptrf.f @@ -0,0 +1,547 @@ + SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION AP( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC, + $ KSTEP, KX, NPP + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1, + $ ROWMAX, T, WK, WKM1, WKP1 +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + EXTERNAL LSAME, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSPR, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPTRF', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* + IF( UPPER ) THEN +* +* 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 + 10 CONTINUE + KNC = KC +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 110 + 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 = ABS( AP( KC+K-1 ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value +* + IF( K.GT.1 ) THEN + IMAX = IDAMAX( K-1, AP( KC ), 1 ) + COLMAX = ABS( AP( KC+IMAX-1 ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE + IF( ABSAKK.GE.ALPHA*COLMAX ) THEN +* +* 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 = ZERO + JMAX = IMAX + KX = IMAX*( IMAX+1 ) / 2 + IMAX + DO 20 J = IMAX + 1, K + IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN + ROWMAX = ABS( AP( KX ) ) + JMAX = J + END IF + KX = KX + J + 20 CONTINUE + KPC = ( IMAX-1 )*IMAX / 2 + 1 + IF( IMAX.GT.1 ) THEN + JMAX = IDAMAX( IMAX-1, AP( KPC ), 1 ) + ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-1 ) ) ) + END IF +* + IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE IF( ABS( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN +* +* 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 + END IF + END IF +* + KK = K - KSTEP + 1 + IF( KSTEP.EQ.2 ) + $ KNC = KNC - K + 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the leading +* submatrix A(1:k,1:k) +* + CALL DSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 ) + KX = KPC + KP - 1 + DO 30 J = KP + 1, KK - 1 + KX = KX + J - 1 + T = AP( KNC+J-1 ) + AP( KNC+J-1 ) = AP( KX ) + AP( KX ) = T + 30 CONTINUE + T = AP( KNC+KK-1 ) + AP( KNC+KK-1 ) = AP( KPC+KP-1 ) + AP( KPC+KP-1 ) = T + IF( KSTEP.EQ.2 ) THEN + T = AP( KC+K-2 ) + AP( KC+K-2 ) = AP( KC+KP-1 ) + AP( KC+KP-1 ) = T + END IF + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* +* 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 = ONE / AP( KC+K-1 ) + CALL DSPR( UPLO, K-1, -R1, AP( KC ), 1, AP ) +* +* Store U(k) in column k +* + CALL DSCAL( K-1, R1, AP( KC ), 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.GT.2 ) THEN +* + 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 = ONE / ( D11*D22-ONE ) + D12 = T / D12 +* + DO 50 J = K - 2, 1, -1 + 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 ) ) + DO 40 I = J, 1, -1 + 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 + 40 CONTINUE + AP( J+( K-1 )*K / 2 ) = WK + AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1 + 50 CONTINUE +* + END IF +* + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -KP + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + KC = KNC - K + GO TO 10 +* + 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 + 60 CONTINUE + KNC = KC +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 110 + 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 = ABS( AP( KC ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value +* + IF( K.LT.N ) THEN + IMAX = K + IDAMAX( N-K, AP( KC+1 ), 1 ) + COLMAX = ABS( AP( KC+IMAX-K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE + IF( ABSAKK.GE.ALPHA*COLMAX ) THEN +* +* 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 = ZERO + KX = KC + IMAX - K + DO 70 J = K, IMAX - 1 + IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN + ROWMAX = ABS( AP( KX ) ) + JMAX = J + END IF + KX = KX + N - J + 70 CONTINUE + KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1 + IF( IMAX.LT.N ) THEN + JMAX = IMAX + IDAMAX( N-IMAX, AP( KPC+1 ), 1 ) + ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-IMAX ) ) ) + END IF +* + IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE IF( ABS( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN +* +* 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 + END IF + END IF +* + KK = K + KSTEP - 1 + IF( KSTEP.EQ.2 ) + $ KNC = KNC + N - K + 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the trailing +* submatrix A(k:n,k:n) +* + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, AP( KNC+KP-KK+1 ), 1, AP( KPC+1 ), + $ 1 ) + KX = KNC + KP - KK + DO 80 J = KK + 1, KP - 1 + KX = KX + N - J + 1 + T = AP( KNC+J-KK ) + AP( KNC+J-KK ) = AP( KX ) + AP( KX ) = T + 80 CONTINUE + T = AP( KNC ) + AP( KNC ) = AP( KPC ) + AP( KPC ) = T + IF( KSTEP.EQ.2 ) THEN + T = AP( KC+1 ) + AP( KC+1 ) = AP( KC+KP-K ) + AP( KC+KP-K ) = T + END IF + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* +* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' +* + R1 = ONE / AP( KC ) + CALL DSPR( UPLO, N-K, -R1, AP( KC+1 ), 1, + $ AP( KC+N-K+1 ) ) +* +* Store L(k) in column K +* + CALL DSCAL( N-K, R1, AP( KC+1 ), 1 ) + END IF + ELSE +* +* 2-by-2 pivot block D(k): columns K and K+1 now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* + IF( K.LT.N-1 ) THEN +* +* 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 )*( 2*N-K ) / 2 ) + D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 + D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 + T = ONE / ( D11*D22-ONE ) + D21 = T / D21 +* + DO 100 J = K + 2, N + WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- + $ AP( J+K*( 2*N-K-1 ) / 2 ) ) + WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- + $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) +* + DO 90 I = J, N + AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* + $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / + $ 2 )*WK - AP( I+K*( 2*N-K-1 ) / 2 )*WKP1 + 90 CONTINUE +* + AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK + AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1 +* + 100 CONTINUE + END IF + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -KP + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + KC = KNC + N - K + 2 + GO TO 60 +* + END IF +* + 110 CONTINUE + RETURN +* +* End of DSPTRF +* + END diff --git a/2.3-1/src/fortran/lapack/dsteqr.f b/2.3-1/src/fortran/lapack/dsteqr.f new file mode 100644 index 00000000..0afd7957 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dsteqr.f @@ -0,0 +1,500 @@ + SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER COMPZ + INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) + INTEGER MAXIT + PARAMETER ( MAXIT = 30 ) +* .. +* .. Local Scalars .. + INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, + $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, + $ NM1, NMAXIT + DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, + $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 + EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR, + $ DLASRT, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( LSAME( COMPZ, 'N' ) ) THEN + ICOMPZ = 0 + ELSE IF( LSAME( COMPZ, 'V' ) ) THEN + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ICOMPZ = 2 + ELSE + ICOMPZ = -1 + END IF + IF( ICOMPZ.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, + $ N ) ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSTEQR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( ICOMPZ.EQ.2 ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* Determine the unit roundoff and over/underflow thresholds. +* + EPS = DLAMCH( 'E' ) + EPS2 = EPS**2 + SAFMIN = DLAMCH( 'S' ) + SAFMAX = ONE / SAFMIN + SSFMAX = SQRT( SAFMAX ) / THREE + SSFMIN = SQRT( SAFMIN ) / EPS2 +* +* Compute the eigenvalues and eigenvectors of the tridiagonal +* matrix. +* + IF( ICOMPZ.EQ.2 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +* + NMAXIT = N*MAXIT + 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 +* + 10 CONTINUE + IF( L1.GT.N ) + $ GO TO 160 + IF( L1.GT.1 ) + $ E( L1-1 ) = ZERO + IF( L1.LE.NM1 ) THEN + DO 20 M = L1, NM1 + TST = ABS( E( M ) ) + IF( TST.EQ.ZERO ) + $ GO TO 30 + IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ + $ 1 ) ) ) )*EPS ) THEN + E( M ) = ZERO + GO TO 30 + END IF + 20 CONTINUE + END IF + M = N +* + 30 CONTINUE + L = L1 + LSV = L + LEND = M + LENDSV = LEND + L1 = M + 1 + IF( LEND.EQ.L ) + $ GO TO 10 +* +* Scale submatrix in rows and columns L to LEND +* + ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) + ISCALE = 0 + IF( ANORM.EQ.ZERO ) + $ GO TO 10 + IF( ANORM.GT.SSFMAX ) THEN + ISCALE = 1 + CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, + $ INFO ) + CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, + $ INFO ) + ELSE IF( ANORM.LT.SSFMIN ) THEN + ISCALE = 2 + CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, + $ INFO ) + CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, + $ INFO ) + END IF +* +* Choose between QL and QR iteration +* + IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN + LEND = LSV + L = LENDSV + END IF +* + IF( LEND.GT.L ) THEN +* +* QL Iteration +* +* Look for small subdiagonal element. +* + 40 CONTINUE + IF( L.NE.LEND ) THEN + LENDM1 = LEND - 1 + DO 50 M = L, LENDM1 + TST = ABS( E( M ) )**2 + IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ + $ SAFMIN )GO TO 60 + 50 CONTINUE + END IF +* + M = LEND +* + 60 CONTINUE + IF( M.LT.LEND ) + $ E( M ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 80 +* +* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 +* to compute its eigensystem. +* + IF( M.EQ.L+1 ) THEN + IF( ICOMPZ.GT.0 ) THEN + CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) + WORK( L ) = C + WORK( N-1+L ) = S + CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ), + $ WORK( N-1+L ), Z( 1, L ), LDZ ) + ELSE + CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) + END IF + D( L ) = RT1 + D( L+1 ) = RT2 + E( L ) = ZERO + L = L + 2 + IF( L.LE.LEND ) + $ GO TO 40 + GO TO 140 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 140 + JTOT = JTOT + 1 +* +* Form shift. +* + G = ( D( L+1 )-P ) / ( TWO*E( L ) ) + R = DLAPY2( G, ONE ) + G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) +* + S = ONE + C = ONE + P = ZERO +* +* Inner loop +* + MM1 = M - 1 + DO 70 I = MM1, L, -1 + F = S*E( I ) + B = C*E( I ) + CALL DLARTG( G, F, C, S, R ) + IF( I.NE.M-1 ) + $ E( I+1 ) = R + G = D( I+1 ) - P + R = ( D( I )-G )*S + TWO*C*B + P = S*R + D( I+1 ) = G + P + G = C*R - B +* +* If eigenvectors are desired, then save rotations. +* + IF( ICOMPZ.GT.0 ) THEN + WORK( I ) = C + WORK( N-1+I ) = -S + END IF +* + 70 CONTINUE +* +* If eigenvectors are desired, then apply saved rotations. +* + IF( ICOMPZ.GT.0 ) THEN + MM = M - L + 1 + CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), + $ Z( 1, L ), LDZ ) + END IF +* + D( L ) = D( L ) - P + E( L ) = G + GO TO 40 +* +* Eigenvalue found. +* + 80 CONTINUE + D( L ) = P +* + L = L + 1 + IF( L.LE.LEND ) + $ GO TO 40 + GO TO 140 +* + ELSE +* +* QR Iteration +* +* Look for small superdiagonal element. +* + 90 CONTINUE + IF( L.NE.LEND ) THEN + LENDP1 = LEND + 1 + DO 100 M = L, LENDP1, -1 + TST = ABS( E( M-1 ) )**2 + IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ + $ SAFMIN )GO TO 110 + 100 CONTINUE + END IF +* + M = LEND +* + 110 CONTINUE + IF( M.GT.LEND ) + $ E( M-1 ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 130 +* +* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 +* to compute its eigensystem. +* + IF( M.EQ.L-1 ) THEN + IF( ICOMPZ.GT.0 ) THEN + CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) + WORK( M ) = C + WORK( N-1+M ) = S + CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), + $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) + ELSE + CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) + END IF + D( L-1 ) = RT1 + D( L ) = RT2 + E( L-1 ) = ZERO + L = L - 2 + IF( L.GE.LEND ) + $ GO TO 90 + GO TO 140 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 140 + JTOT = JTOT + 1 +* +* Form shift. +* + G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) + R = DLAPY2( G, ONE ) + G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) +* + S = ONE + C = ONE + P = ZERO +* +* Inner loop +* + LM1 = L - 1 + DO 120 I = M, LM1 + F = S*E( I ) + B = C*E( I ) + CALL DLARTG( G, F, C, S, R ) + IF( I.NE.M ) + $ E( I-1 ) = R + G = D( I ) - P + R = ( D( I+1 )-G )*S + TWO*C*B + P = S*R + D( I ) = G + P + G = C*R - B +* +* If eigenvectors are desired, then save rotations. +* + IF( ICOMPZ.GT.0 ) THEN + WORK( I ) = C + WORK( N-1+I ) = S + END IF +* + 120 CONTINUE +* +* If eigenvectors are desired, then apply saved rotations. +* + IF( ICOMPZ.GT.0 ) THEN + MM = L - M + 1 + CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), + $ Z( 1, M ), LDZ ) + END IF +* + D( L ) = D( L ) - P + E( LM1 ) = G + GO TO 90 +* +* Eigenvalue found. +* + 130 CONTINUE + D( L ) = P +* + L = L - 1 + IF( L.GE.LEND ) + $ GO TO 90 + GO TO 140 +* + END IF +* +* Undo scaling if necessary +* + 140 CONTINUE + IF( ISCALE.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, + $ D( LSV ), N, INFO ) + CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), + $ N, INFO ) + ELSE IF( ISCALE.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, + $ D( LSV ), N, INFO ) + CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), + $ N, INFO ) + END IF +* +* Check for no convergence to an eigenvalue after a total +* of N*MAXIT iterations. +* + IF( JTOT.LT.NMAXIT ) + $ GO TO 10 + DO 150 I = 1, N - 1 + IF( E( I ).NE.ZERO ) + $ INFO = INFO + 1 + 150 CONTINUE + GO TO 190 +* +* Order eigenvalues and eigenvectors. +* + 160 CONTINUE + IF( ICOMPZ.EQ.0 ) THEN +* +* Use Quick Sort +* + CALL DLASRT( 'I', N, D, INFO ) +* + ELSE +* +* Use Selection Sort to minimize swaps of eigenvectors +* + DO 180 II = 2, N + I = II - 1 + K = I + P = D( I ) + DO 170 J = II, N + IF( D( J ).LT.P ) THEN + K = J + P = D( J ) + END IF + 170 CONTINUE + IF( K.NE.I ) THEN + D( K ) = D( I ) + D( I ) = P + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) + END IF + 180 CONTINUE + END IF +* + 190 CONTINUE + RETURN +* +* End of DSTEQR +* + END diff --git a/2.3-1/src/fortran/lapack/dsterf.f b/2.3-1/src/fortran/lapack/dsterf.f new file mode 100644 index 00000000..c17ea23a --- /dev/null +++ b/2.3-1/src/fortran/lapack/dsterf.f @@ -0,0 +1,364 @@ + SUBROUTINE DSTERF( N, D, E, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) + INTEGER MAXIT + PARAMETER ( MAXIT = 30 ) +* .. +* .. Local Scalars .. + INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M, + $ NMAXIT + DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC, + $ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN, + $ SIGMA, SSFMAX, SSFMIN +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 + EXTERNAL DLAMCH, DLANST, DLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL DLAE2, DLASCL, DLASRT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* +* Quick return if possible +* + IF( N.LT.0 ) THEN + INFO = -1 + CALL XERBLA( 'DSTERF', -INFO ) + RETURN + END IF + IF( N.LE.1 ) + $ RETURN +* +* Determine the unit roundoff for this environment. +* + EPS = DLAMCH( 'E' ) + EPS2 = EPS**2 + SAFMIN = DLAMCH( 'S' ) + SAFMAX = ONE / SAFMIN + SSFMAX = SQRT( SAFMAX ) / THREE + SSFMIN = SQRT( SAFMIN ) / EPS2 +* +* Compute the eigenvalues of the tridiagonal matrix. +* + NMAXIT = N*MAXIT + SIGMA = ZERO + 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 +* + 10 CONTINUE + IF( L1.GT.N ) + $ GO TO 170 + IF( L1.GT.1 ) + $ E( L1-1 ) = ZERO + DO 20 M = L1, N - 1 + IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ + $ 1 ) ) ) )*EPS ) THEN + E( M ) = ZERO + GO TO 30 + END IF + 20 CONTINUE + M = N +* + 30 CONTINUE + L = L1 + LSV = L + LEND = M + LENDSV = LEND + L1 = M + 1 + IF( LEND.EQ.L ) + $ GO TO 10 +* +* Scale submatrix in rows and columns L to LEND +* + ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) + ISCALE = 0 + IF( ANORM.GT.SSFMAX ) THEN + ISCALE = 1 + CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, + $ INFO ) + CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, + $ INFO ) + ELSE IF( ANORM.LT.SSFMIN ) THEN + ISCALE = 2 + CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, + $ INFO ) + CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, + $ INFO ) + END IF +* + DO 40 I = L, LEND - 1 + E( I ) = E( I )**2 + 40 CONTINUE +* +* Choose between QL and QR iteration +* + IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN + LEND = LSV + L = LENDSV + END IF +* + IF( LEND.GE.L ) THEN +* +* QL Iteration +* +* Look for small subdiagonal element. +* + 50 CONTINUE + IF( L.NE.LEND ) THEN + DO 60 M = L, LEND - 1 + IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) ) + $ GO TO 70 + 60 CONTINUE + END IF + M = LEND +* + 70 CONTINUE + IF( M.LT.LEND ) + $ E( M ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 90 +* +* If remaining matrix is 2 by 2, use DLAE2 to compute its +* eigenvalues. +* + IF( M.EQ.L+1 ) THEN + RTE = SQRT( E( L ) ) + CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 ) + D( L ) = RT1 + D( L+1 ) = RT2 + E( L ) = ZERO + L = L + 2 + IF( L.LE.LEND ) + $ GO TO 50 + GO TO 150 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 150 + JTOT = JTOT + 1 +* +* Form shift. +* + RTE = SQRT( E( L ) ) + SIGMA = ( D( L+1 )-P ) / ( TWO*RTE ) + R = DLAPY2( SIGMA, ONE ) + SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) +* + C = ONE + S = ZERO + GAMMA = D( M ) - SIGMA + P = GAMMA*GAMMA +* +* Inner loop +* + DO 80 I = M - 1, L, -1 + BB = E( I ) + R = P + BB + IF( I.NE.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.NE.ZERO ) THEN + P = ( GAMMA*GAMMA ) / C + ELSE + P = OLDC*BB + END IF + 80 CONTINUE +* + E( L ) = S*P + D( L ) = SIGMA + GAMMA + GO TO 50 +* +* Eigenvalue found. +* + 90 CONTINUE + D( L ) = P +* + L = L + 1 + IF( L.LE.LEND ) + $ GO TO 50 + GO TO 150 +* + ELSE +* +* QR Iteration +* +* Look for small superdiagonal element. +* + 100 CONTINUE + DO 110 M = L, LEND + 1, -1 + IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) ) + $ GO TO 120 + 110 CONTINUE + M = LEND +* + 120 CONTINUE + IF( M.GT.LEND ) + $ E( M-1 ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 140 +* +* If remaining matrix is 2 by 2, use DLAE2 to compute its +* eigenvalues. +* + IF( M.EQ.L-1 ) THEN + RTE = SQRT( E( L-1 ) ) + CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 ) + D( L ) = RT1 + D( L-1 ) = RT2 + E( L-1 ) = ZERO + L = L - 2 + IF( L.GE.LEND ) + $ GO TO 100 + GO TO 150 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 150 + JTOT = JTOT + 1 +* +* Form shift. +* + RTE = SQRT( E( L-1 ) ) + SIGMA = ( D( L-1 )-P ) / ( TWO*RTE ) + R = DLAPY2( SIGMA, ONE ) + SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) +* + C = ONE + S = ZERO + GAMMA = D( M ) - SIGMA + P = GAMMA*GAMMA +* +* Inner loop +* + DO 130 I = M, L - 1 + BB = E( I ) + R = P + BB + IF( I.NE.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.NE.ZERO ) THEN + P = ( GAMMA*GAMMA ) / C + ELSE + P = OLDC*BB + END IF + 130 CONTINUE +* + E( L-1 ) = S*P + D( L ) = SIGMA + GAMMA + GO TO 100 +* +* Eigenvalue found. +* + 140 CONTINUE + D( L ) = P +* + L = L - 1 + IF( L.GE.LEND ) + $ GO TO 100 + GO TO 150 +* + END IF +* +* Undo scaling if necessary +* + 150 CONTINUE + IF( ISCALE.EQ.1 ) + $ CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, + $ D( LSV ), N, INFO ) + IF( ISCALE.EQ.2 ) + $ CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, + $ D( LSV ), N, INFO ) +* +* Check for no convergence to an eigenvalue after a total +* of N*MAXIT iterations. +* + IF( JTOT.LT.NMAXIT ) + $ GO TO 10 + DO 160 I = 1, N - 1 + IF( E( I ).NE.ZERO ) + $ INFO = INFO + 1 + 160 CONTINUE + GO TO 180 +* +* Sort eigenvalues in increasing order. +* + 170 CONTINUE + CALL DLASRT( 'I', N, D, INFO ) +* + 180 CONTINUE + RETURN +* +* End of DSTERF +* + END diff --git a/2.3-1/src/fortran/lapack/dsycon.f b/2.3-1/src/fortran/lapack/dsycon.f new file mode 100644 index 00000000..711b48ca --- /dev/null +++ b/2.3-1/src/fortran/lapack/dsycon.f @@ -0,0 +1,165 @@ + SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, + $ IWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, KASE + DOUBLE PRECISION AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DSYTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYCON', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.LE.ZERO ) THEN + RETURN + END IF +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO 10 I = N, 1, -1 + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO 20 I = 1, N + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + 20 CONTINUE + END IF +* +* Estimate the 1-norm of the inverse. +* + KASE = 0 + 30 CONTINUE + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN +* +* Multiply by inv(L*D*L') or inv(U*D*U'). +* + CALL DSYTRS( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO ) + GO TO 30 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + RETURN +* +* End of DSYCON +* + END diff --git a/2.3-1/src/fortran/lapack/dsyev.f b/2.3-1/src/fortran/lapack/dsyev.f new file mode 100644 index 00000000..d73600a2 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dsyev.f @@ -0,0 +1,211 @@ + SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, + $ LLWORK, LWKOPT, NB + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, DSYTRD, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( 1, ( NB+2 )*N ) + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) + $ INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYEV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + RETURN + END IF +* + IF( N.EQ.1 ) THEN + W( 1 ) = A( 1, 1 ) + WORK( 1 ) = 2 + IF( WANTZ ) + $ A( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) + $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) +* +* Call DSYTRD to reduce symmetric matrix to tridiagonal form. +* + INDE = 1 + INDTAU = INDE + N + INDWRK = INDTAU + N + LLWORK = LWORK - INDWRK + 1 + CALL DSYTRD( UPLO, N, A, LDA, W, 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( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE + CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), + $ LLWORK, IINFO ) + CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ), + $ INFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYEV +* + END diff --git a/2.3-1/src/fortran/lapack/dsysv.f b/2.3-1/src/fortran/lapack/dsysv.f new file mode 100644 index 00000000..add53850 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dsysv.f @@ -0,0 +1,174 @@ + SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* 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 .. + LOGICAL LQUERY + INTEGER LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DSYTRF, DSYTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYSV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*D*U' or A = L*D*L'. +* + CALL DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYSV +* + END diff --git a/2.3-1/src/fortran/lapack/dsytd2.f b/2.3-1/src/fortran/lapack/dsytd2.f new file mode 100644 index 00000000..c696818e --- /dev/null +++ b/2.3-1/src/fortran/lapack/dsytd2.f @@ -0,0 +1,248 @@ + SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO, HALF + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, + $ HALF = 1.0D0 / 2.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I + DOUBLE PRECISION ALPHA, TAUI +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DLARFG, DSYMV, DSYR2, XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTD2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Reduce the upper triangle of A +* + DO 10 I = N - 1, 1, -1 +* +* Generate elementary reflector H(i) = I - tau * v * v' +* to annihilate A(1:i-1,i+1) +* + CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI ) + E( I ) = A( I, I+1 ) +* + IF( TAUI.NE.ZERO ) THEN +* +* Apply H(i) from both sides to A(1:i,1:i) +* + A( I, I+1 ) = ONE +* +* Compute x := tau * A * v storing x in TAU(1:i) +* + CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, + $ TAU, 1 ) +* +* Compute w := x - 1/2 * tau * (x'*v) * v +* + ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 ) + CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) +* +* Apply the transformation as a rank-2 update: +* A := A - v * w' - w * v' +* + CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, + $ LDA ) +* + A( I, I+1 ) = E( I ) + END IF + D( I+1 ) = A( I+1, I+1 ) + TAU( I ) = TAUI + 10 CONTINUE + D( 1 ) = A( 1, 1 ) + ELSE +* +* Reduce the lower triangle of A +* + DO 20 I = 1, N - 1 +* +* Generate elementary reflector H(i) = I - tau * v * v' +* to annihilate A(i+2:n,i) +* + CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAUI ) + E( I ) = A( I+1, I ) +* + IF( TAUI.NE.ZERO ) THEN +* +* Apply H(i) from both sides to A(i+1:n,i+1:n) +* + A( I+1, I ) = ONE +* +* Compute x := tau * A * v storing y in TAU(i:n-1) +* + CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, + $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) +* +* Compute w := x - 1/2 * tau * (x'*v) * v +* + ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ), + $ 1 ) + CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) +* +* Apply the transformation as a rank-2 update: +* A := A - v * w' - w * v' +* + CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, + $ A( I+1, I+1 ), LDA ) +* + A( I+1, I ) = E( I ) + END IF + D( I ) = A( I, I ) + TAU( I ) = TAUI + 20 CONTINUE + D( N ) = A( N, N ) + END IF +* + RETURN +* +* End of DSYTD2 +* + END diff --git a/2.3-1/src/fortran/lapack/dsytf2.f b/2.3-1/src/fortran/lapack/dsytf2.f new file mode 100644 index 00000000..d5234625 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dsytf2.f @@ -0,0 +1,521 @@ + SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1, + $ ROWMAX, T, WK, WKM1, WKP1 +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + INTEGER IDAMAX + EXTERNAL LSAME, IDAMAX, DISNAN +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, DSYR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTF2', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* + IF( UPPER ) THEN +* +* 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 + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 70 + 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 = ABS( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value +* + IF( K.GT.1 ) THEN + IMAX = IDAMAX( K-1, A( 1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN +* +* Column K is zero or contains a NaN: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE + IF( ABSAKK.GE.ALPHA*COLMAX ) THEN +* +* 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 +* + JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA ) + ROWMAX = ABS( A( IMAX, JMAX ) ) + IF( IMAX.GT.1 ) THEN + JMAX = IDAMAX( IMAX-1, A( 1, IMAX ), 1 ) + ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) + END IF +* + IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN +* +* 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 + END IF + END IF +* + KK = K - KSTEP + 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the leading +* submatrix A(1:k,1:k) +* + CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) + CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K-1, K ) + A( K-1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* +* 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 = ONE / A( K, K ) + CALL DSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA ) +* +* Store U(k) in column k +* + CALL DSCAL( K-1, R1, A( 1, K ), 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.GT.2 ) THEN +* + D12 = A( K-1, K ) + D22 = A( K-1, K-1 ) / D12 + D11 = A( K, K ) / D12 + T = ONE / ( D11*D22-ONE ) + D12 = T / D12 +* + DO 30 J = K - 2, 1, -1 + WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) ) + WK = D12*( D22*A( J, K )-A( J, K-1 ) ) + DO 20 I = J, 1, -1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 + 20 CONTINUE + A( J, K ) = WK + A( J, K-1 ) = WKM1 + 30 CONTINUE +* + END IF +* + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -KP + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 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 + 40 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 70 + 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 = ABS( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value +* + IF( K.LT.N ) THEN + IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN +* +* Column K is zero or contains a NaN: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE + IF( ABSAKK.GE.ALPHA*COLMAX ) THEN +* +* 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 +* + JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA ) + ROWMAX = ABS( A( IMAX, JMAX ) ) + IF( IMAX.LT.N ) THEN + JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 ) + ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) + END IF +* + IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN +* +* 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 + END IF + END IF +* + KK = K + KSTEP - 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the trailing +* submatrix A(k:n,k:n) +* + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K+1, K ) + A( K+1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* +* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' +* + D11 = ONE / A( K, K ) + CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* Store L(k) in column K +* + CALL DSCAL( N-K, D11, A( K+1, K ), 1 ) + END IF + ELSE +* +* 2-by-2 pivot block D(k) +* + IF( K.LT.N-1 ) THEN +* +* 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 ) + D11 = A( K+1, K+1 ) / D21 + D22 = A( K, K ) / D21 + T = ONE / ( D11*D22-ONE ) + D21 = T / D21 +* + DO 60 J = K + 2, N +* + WK = D21*( D11*A( J, K )-A( J, K+1 ) ) + WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) ) +* + DO 50 I = J, N + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 + 50 CONTINUE +* + A( J, K ) = WK + A( J, K+1 ) = WKP1 +* + 60 CONTINUE + END IF + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -KP + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 40 +* + END IF +* + 70 CONTINUE +* + RETURN +* +* End of DSYTF2 +* + END diff --git a/2.3-1/src/fortran/lapack/dsytrd.f b/2.3-1/src/fortran/lapack/dsytrd.f new file mode 100644 index 00000000..569ee35b --- /dev/null +++ b/2.3-1/src/fortran/lapack/dsytrd.f @@ -0,0 +1,294 @@ + SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), + $ WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DLATRD, DSYR2K, DSYTD2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. +* + NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NX = N + IWS = 1 + IF( NB.GT.1 .AND. NB.LT.N ) THEN +* +* Determine when to cross over from blocked to unblocked code +* (last block is always handled by unblocked code). +* + NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) + IF( NX.LT.N ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* 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. +* + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 ) + IF( NB.LT.NBMIN ) + $ NX = N + END IF + ELSE + NX = N + END IF + ELSE + NB = 1 + END IF +* + IF( UPPER ) THEN +* +* Reduce the upper triangle of A. +* Columns 1:kk are handled by the unblocked method. +* + KK = N - ( ( N-NX+NB-1 ) / NB )*NB + DO 20 I = N - NB + 1, KK + 1, -NB +* +* 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 +* + CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, + $ LDWORK ) +* +* Update the unreduced submatrix A(1:i-1,1:i-1), using an +* update of the form: A := A - V*W' - W*V' +* + CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ), + $ LDA, WORK, LDWORK, ONE, A, LDA ) +* +* Copy superdiagonal elements back into A, and diagonal +* elements into D +* + DO 10 J = I, I + NB - 1 + A( J-1, J ) = E( J-1 ) + D( J ) = A( J, J ) + 10 CONTINUE + 20 CONTINUE +* +* Use unblocked code to reduce the last or only block +* + CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) + ELSE +* +* Reduce the lower triangle of A +* + DO 40 I = 1, N - NX, NB +* +* 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 +* + CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), + $ TAU( I ), WORK, LDWORK ) +* +* Update the unreduced submatrix A(i+ib:n,i+ib:n), using +* an update of the form: A := A - V*W' - W*V' +* + CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE, + $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, + $ A( I+NB, I+NB ), LDA ) +* +* Copy subdiagonal elements back into A, and diagonal +* elements into D +* + DO 30 J = I, I + NB - 1 + A( J+1, J ) = E( J ) + D( J ) = A( J, J ) + 30 CONTINUE + 40 CONTINUE +* +* Use unblocked code to reduce the last or only block +* + CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), + $ TAU( I ), IINFO ) + END IF +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of DSYTRD +* + END diff --git a/2.3-1/src/fortran/lapack/dsytrf.f b/2.3-1/src/fortran/lapack/dsytrf.f new file mode 100644 index 00000000..43a31248 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dsytrf.f @@ -0,0 +1,287 @@ + SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* 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 .. + LOGICAL LQUERY, UPPER + INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLASYF, DSYTF2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size +* + NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF', UPLO, N, -1, -1, -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U' 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 + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 40 +* + IF( K.GT.NB ) THEN +* +* Factorize columns k-kb+1:k of A and use blocked code to +* update columns 1:k-kb +* + CALL DLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK, + $ IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL DSYTF2( UPLO, K, A, LDA, IPIV, IINFO ) + KB = K + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* + 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 + 20 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 40 +* + IF( K.LE.N-NB ) THEN +* +* Factorize columns k:k+kb-1 of A and use blocked code to +* update columns k+kb:n +* + CALL DLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ), + $ WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns k:n of A +* + CALL DSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO ) + KB = N - K + 1 + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* Adjust IPIV +* + DO 30 J = K, K + KB - 1 + IF( IPIV( J ).GT.0 ) THEN + IPIV( J ) = IPIV( J ) + K - 1 + ELSE + IPIV( J ) = IPIV( J ) - K + 1 + END IF + 30 CONTINUE +* +* Increase K and return to the start of the main loop +* + K = K + KB + GO TO 20 +* + END IF +* + 40 CONTINUE + WORK( 1 ) = LWKOPT + RETURN +* +* End of DSYTRF +* + END diff --git a/2.3-1/src/fortran/lapack/dsytri.f b/2.3-1/src/fortran/lapack/dsytri.f new file mode 100644 index 00000000..361de9a3 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dsytri.f @@ -0,0 +1,312 @@ + SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, KP, KSTEP + DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSWAP, DSYMV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO 10 INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO 20 INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) + $ RETURN + 20 CONTINUE + END IF + INFO = 0 +* + IF( UPPER ) THEN +* +* 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 + 30 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 40 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + A( K, K ) = ONE / A( K, K ) +* +* Compute column K of the inverse. +* + IF( K.GT.1 ) THEN + CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, + $ A( 1, K ), 1 ) + A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), + $ 1 ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = ABS( A( K, K+1 ) ) + AK = A( K, K ) / T + AKP1 = A( K+1, K+1 ) / T + AKKP1 = A( K, K+1 ) / T + D = T*( AK*AKP1-ONE ) + A( K, K ) = AKP1 / D + A( K+1, K+1 ) = AK / D + A( K, K+1 ) = -AKKP1 / D +* +* Compute columns K and K+1 of the inverse. +* + IF( K.GT.1 ) THEN + CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, + $ A( 1, K ), 1 ) + A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), + $ 1 ) + A( K, K+1 ) = A( K, K+1 ) - + $ DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 ) + CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 ) + CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, + $ A( 1, K+1 ), 1 ) + A( K+1, K+1 ) = A( K+1, K+1 ) - + $ DDOT( K-1, WORK, 1, A( 1, K+1 ), 1 ) + END IF + KSTEP = 2 + END IF +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN +* +* Interchange rows and columns K and KP in the leading +* submatrix A(1:k+1,1:k+1) +* + CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + IF( KSTEP.EQ.2 ) THEN + TEMP = A( K, K+1 ) + A( K, K+1 ) = A( KP, K+1 ) + A( KP, K+1 ) = TEMP + END IF + END IF +* + K = K + KSTEP + GO TO 30 + 40 CONTINUE +* + 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 + 50 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 60 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + A( K, K ) = ONE / A( K, K ) +* +* Compute column K of the inverse. +* + IF( K.LT.N ) THEN + CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, + $ ZERO, A( K+1, K ), 1 ) + A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), + $ 1 ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = ABS( A( K, K-1 ) ) + AK = A( K-1, K-1 ) / T + AKP1 = A( K, K ) / T + AKKP1 = A( K, K-1 ) / T + D = T*( AK*AKP1-ONE ) + A( K-1, K-1 ) = AKP1 / D + A( K, K ) = AK / D + A( K, K-1 ) = -AKKP1 / D +* +* Compute columns K-1 and K of the inverse. +* + IF( K.LT.N ) THEN + CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, + $ ZERO, A( K+1, K ), 1 ) + A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), + $ 1 ) + A( K, K-1 ) = A( K, K-1 ) - + $ DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ), + $ 1 ) + CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 ) + CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, + $ ZERO, A( K+1, K-1 ), 1 ) + A( K-1, K-1 ) = A( K-1, K-1 ) - + $ DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 ) + END IF + KSTEP = 2 + END IF +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN +* +* Interchange rows and columns K and KP in the trailing +* submatrix A(k-1:n,k-1:n) +* + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + IF( KSTEP.EQ.2 ) THEN + TEMP = A( K, K-1 ) + A( K, K-1 ) = A( KP, K-1 ) + A( KP, K-1 ) = TEMP + END IF + END IF +* + K = K - KSTEP + GO TO 50 + 60 CONTINUE + END IF +* + RETURN +* +* End of DSYTRI +* + END diff --git a/2.3-1/src/fortran/lapack/dsytrs.f b/2.3-1/src/fortran/lapack/dsytrs.f new file mode 100644 index 00000000..163ed5b9 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dsytrs.f @@ -0,0 +1,369 @@ + SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, K, KP + DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*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 + 10 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 30 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in column K of A. +* + CALL DGER( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB ) + K = K - 1 + ELSE +* +* 2 x 2 diagonal block +* +* Interchange rows K-1 and -IPIV(K). +* + KP = -IPIV( K ) + IF( KP.NE.K-1 ) + $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in columns K-1 and K of A. +* + CALL DGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) + CALL DGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), + $ LDB, B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + AKM1K = A( K-1, K ) + AKM1 = A( K-1, K-1 ) / AKM1K + AK = A( K, K ) / AKM1K + DENOM = AKM1*AK - ONE + DO 20 J = 1, NRHS + BKM1 = B( K-1, J ) / AKM1K + BK = B( K, J ) / AKM1K + B( K-1, J ) = ( AK*BKM1-BK ) / DENOM + B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM + 20 CONTINUE + K = K - 2 + END IF +* + GO TO 10 + 30 CONTINUE +* +* 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 + 40 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 50 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Multiply by inv(U'(K)), where U(K) is the transformation +* stored in column K of A. +* + CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ), + $ 1, ONE, B( K, 1 ), LDB ) +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K + 1 + 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. +* + CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ), + $ 1, ONE, B( K, 1 ), LDB ) + CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, + $ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) +* +* Interchange rows K and -IPIV(K). +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K + 2 + END IF +* + GO TO 40 + 50 CONTINUE +* + 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 + 60 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 80 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in column K of A. +* + IF( K.LT.N ) + $ CALL DGER( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ), + $ LDB, B( K+1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB ) + K = K + 1 + ELSE +* +* 2 x 2 diagonal block +* +* Interchange rows K+1 and -IPIV(K). +* + KP = -IPIV( K ) + IF( KP.NE.K+1 ) + $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.LT.N-1 ) THEN + CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ), + $ LDB, B( K+2, 1 ), LDB ) + CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. +* + AKM1K = A( K+1, K ) + AKM1 = A( K, K ) / AKM1K + AK = A( K+1, K+1 ) / AKM1K + DENOM = AKM1*AK - ONE + DO 70 J = 1, NRHS + BKM1 = B( K, J ) / AKM1K + BK = B( K+1, J ) / AKM1K + B( K, J ) = ( AK*BKM1-BK ) / DENOM + B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM + 70 CONTINUE + K = K + 2 + END IF +* + GO TO 60 + 80 CONTINUE +* +* 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 + 90 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 100 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Multiply by inv(L'(K)), where L(K) is the transformation +* stored in column K of A. +* + IF( K.LT.N ) + $ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K - 1 + 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.LT.N ) THEN + CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ), + $ LDB ) + END IF +* +* Interchange rows K and -IPIV(K). +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K - 2 + END IF +* + GO TO 90 + 100 CONTINUE + END IF +* + RETURN +* +* End of DSYTRS +* + END diff --git a/2.3-1/src/fortran/lapack/dtgevc.f b/2.3-1/src/fortran/lapack/dtgevc.f new file mode 100644 index 00000000..091c3f65 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dtgevc.f @@ -0,0 +1,1147 @@ + SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, + $ LDVL, VR, LDVR, MM, M, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER HOWMNY, SIDE + INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + DOUBLE PRECISION P( LDP, * ), S( LDS, * ), VL( LDVL, * ), + $ VR( LDVR, * ), WORK( * ) +* .. +* +* +* 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 .. + DOUBLE PRECISION ZERO, ONE, SAFETY + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, + $ SAFETY = 1.0D+2 ) +* .. +* .. Local Scalars .. + LOGICAL COMPL, COMPR, IL2BY2, ILABAD, ILALL, ILBACK, + $ ILBBAD, ILCOMP, ILCPLX, LSA, LSB + INTEGER I, IBEG, IEIG, IEND, IHWMNY, IINFO, IM, ISIDE, + $ J, JA, JC, JE, JR, JW, NA, NW + DOUBLE PRECISION ACOEF, ACOEFA, ANORM, ASCALE, BCOEFA, BCOEFI, + $ BCOEFR, BIG, BIGNUM, BNORM, BSCALE, CIM2A, + $ CIM2B, CIMAGA, CIMAGB, CRE2A, CRE2B, CREALA, + $ CREALB, DMIN, SAFMIN, SALFAR, SBETA, SCALE, + $ SMALL, TEMP, TEMP2, TEMP2I, TEMP2R, ULP, XMAX, + $ XSCALE +* .. +* .. Local Arrays .. + DOUBLE PRECISION BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ), + $ SUMP( 2, 2 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DLABAD, DLACPY, DLAG2, DLALN2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* +* Decode and Test the input parameters +* + IF( LSAME( HOWMNY, 'A' ) ) THEN + IHWMNY = 1 + ILALL = .TRUE. + ILBACK = .FALSE. + ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN + IHWMNY = 2 + ILALL = .FALSE. + ILBACK = .FALSE. + ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN + IHWMNY = 3 + ILALL = .TRUE. + ILBACK = .TRUE. + ELSE + IHWMNY = -1 + ILALL = .TRUE. + END IF +* + IF( LSAME( SIDE, 'R' ) ) THEN + ISIDE = 1 + COMPL = .FALSE. + COMPR = .TRUE. + ELSE IF( LSAME( SIDE, 'L' ) ) THEN + ISIDE = 2 + COMPL = .TRUE. + COMPR = .FALSE. + ELSE IF( LSAME( SIDE, 'B' ) ) THEN + ISIDE = 3 + COMPL = .TRUE. + COMPR = .TRUE. + ELSE + ISIDE = -1 + END IF +* + INFO = 0 + IF( ISIDE.LT.0 ) THEN + INFO = -1 + ELSE IF( IHWMNY.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDP.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTGEVC', -INFO ) + RETURN + END IF +* +* Count the number of eigenvectors to be computed +* + IF( .NOT.ILALL ) THEN + IM = 0 + ILCPLX = .FALSE. + DO 10 J = 1, N + IF( ILCPLX ) THEN + ILCPLX = .FALSE. + GO TO 10 + END IF + IF( J.LT.N ) THEN + IF( S( J+1, J ).NE.ZERO ) + $ ILCPLX = .TRUE. + END IF + IF( ILCPLX ) THEN + IF( SELECT( J ) .OR. SELECT( J+1 ) ) + $ IM = IM + 2 + ELSE + IF( SELECT( J ) ) + $ IM = IM + 1 + END IF + 10 CONTINUE + ELSE + IM = N + END IF +* +* Check 2-by-2 diagonal blocks of A, B +* + ILABAD = .FALSE. + ILBBAD = .FALSE. + DO 20 J = 1, N - 1 + IF( S( J+1, J ).NE.ZERO ) THEN + IF( P( J, J ).EQ.ZERO .OR. P( J+1, J+1 ).EQ.ZERO .OR. + $ P( J, J+1 ).NE.ZERO )ILBBAD = .TRUE. + IF( J.LT.N-1 ) THEN + IF( S( J+2, J+1 ).NE.ZERO ) + $ ILABAD = .TRUE. + END IF + END IF + 20 CONTINUE +* + IF( ILABAD ) THEN + INFO = -5 + ELSE IF( ILBBAD ) THEN + INFO = -7 + ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN + INFO = -10 + ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN + INFO = -12 + ELSE IF( MM.LT.IM ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTGEVC', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + M = IM + IF( N.EQ.0 ) + $ RETURN +* +* Machine Constants +* + SAFMIN = DLAMCH( 'Safe minimum' ) + BIG = ONE / SAFMIN + CALL DLABAD( SAFMIN, BIG ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + SMALL = SAFMIN*N / ULP + BIG = ONE / SMALL + BIGNUM = ONE / ( 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 = ABS( S( 1, 1 ) ) + IF( N.GT.1 ) + $ ANORM = ANORM + ABS( S( 2, 1 ) ) + BNORM = ABS( P( 1, 1 ) ) + WORK( 1 ) = ZERO + WORK( N+1 ) = ZERO +* + DO 50 J = 2, N + TEMP = ZERO + TEMP2 = ZERO + IF( S( J, J-1 ).EQ.ZERO ) THEN + IEND = J - 1 + ELSE + IEND = J - 2 + END IF + DO 30 I = 1, IEND + TEMP = TEMP + ABS( S( I, J ) ) + TEMP2 = TEMP2 + ABS( P( I, J ) ) + 30 CONTINUE + WORK( J ) = TEMP + WORK( N+J ) = TEMP2 + DO 40 I = IEND + 1, MIN( J+1, N ) + TEMP = TEMP + ABS( S( I, J ) ) + TEMP2 = TEMP2 + ABS( P( I, J ) ) + 40 CONTINUE + ANORM = MAX( ANORM, TEMP ) + BNORM = MAX( BNORM, TEMP2 ) + 50 CONTINUE +* + ASCALE = ONE / MAX( ANORM, SAFMIN ) + BSCALE = ONE / MAX( BNORM, SAFMIN ) +* +* Left eigenvectors +* + IF( COMPL ) THEN + IEIG = 0 +* +* Main loop over eigenvalues +* + ILCPLX = .FALSE. + DO 220 JE = 1, N +* +* 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 ) THEN + ILCPLX = .FALSE. + GO TO 220 + END IF + NW = 1 + IF( JE.LT.N ) THEN + IF( S( JE+1, JE ).NE.ZERO ) THEN + ILCPLX = .TRUE. + NW = 2 + END IF + END IF + IF( ILALL ) THEN + ILCOMP = .TRUE. + ELSE IF( ILCPLX ) THEN + ILCOMP = SELECT( JE ) .OR. SELECT( JE+1 ) + ELSE + ILCOMP = SELECT( JE ) + END IF + IF( .NOT.ILCOMP ) + $ GO TO 220 +* +* Decide if (a) singular pencil, (b) real eigenvalue, or +* (c) complex eigenvalue. +* + IF( .NOT.ILCPLX ) THEN + IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN +* +* Singular matrix pencil -- return unit eigenvector +* + IEIG = IEIG + 1 + DO 60 JR = 1, N + VL( JR, IEIG ) = ZERO + 60 CONTINUE + VL( IEIG, IEIG ) = ONE + GO TO 220 + END IF + END IF +* +* Clear vector +* + DO 70 JR = 1, NW*N + WORK( 2*N+JR ) = ZERO + 70 CONTINUE +* T +* Compute coefficients in ( a A - b B ) y = 0 +* a is ACOEF +* b is BCOEFR + i*BCOEFI +* + IF( .NOT.ILCPLX ) THEN +* +* Real eigenvalue +* + TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, + $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) + SALFAR = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*P( JE, JE ) )*BSCALE + ACOEF = SBETA*ASCALE + BCOEFR = SALFAR*BSCALE + BCOEFI = ZERO +* +* Scale to avoid underflow +* + SCALE = ONE + LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL + LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT. + $ SMALL + IF( LSA ) + $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) + IF( LSB ) + $ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )* + $ MIN( BNORM, BIG ) ) + IF( LSA .OR. LSB ) THEN + SCALE = MIN( SCALE, ONE / + $ ( SAFMIN*MAX( ONE, ABS( ACOEF ), + $ ABS( BCOEFR ) ) ) ) + IF( LSA ) THEN + ACOEF = ASCALE*( SCALE*SBETA ) + ELSE + ACOEF = SCALE*ACOEF + END IF + IF( LSB ) THEN + BCOEFR = BSCALE*( SCALE*SALFAR ) + ELSE + BCOEFR = SCALE*BCOEFR + END IF + END IF + ACOEFA = ABS( ACOEF ) + BCOEFA = ABS( BCOEFR ) +* +* First component is 1 +* + WORK( 2*N+JE ) = ONE + XMAX = ONE + ELSE +* +* Complex eigenvalue +* + CALL DLAG2( S( JE, JE ), LDS, P( JE, JE ), LDP, + $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, + $ BCOEFI ) + BCOEFI = -BCOEFI + IF( BCOEFI.EQ.ZERO ) THEN + INFO = JE + RETURN + END IF +* +* Scale to avoid over/underflow +* + ACOEFA = ABS( ACOEF ) + BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI ) + SCALE = ONE + IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN ) + $ SCALE = ( SAFMIN / ULP ) / ACOEFA + IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN ) + $ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA ) + IF( SAFMIN*ACOEFA.GT.ASCALE ) + $ SCALE = ASCALE / ( SAFMIN*ACOEFA ) + IF( SAFMIN*BCOEFA.GT.BSCALE ) + $ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) ) + IF( SCALE.NE.ONE ) THEN + ACOEF = SCALE*ACOEF + ACOEFA = ABS( ACOEF ) + BCOEFR = SCALE*BCOEFR + BCOEFI = SCALE*BCOEFI + BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI ) + END IF +* +* Compute first two components of eigenvector +* + TEMP = ACOEF*S( JE+1, JE ) + TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) + TEMP2I = -BCOEFI*P( JE, JE ) + IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN + WORK( 2*N+JE ) = ONE + WORK( 3*N+JE ) = ZERO + WORK( 2*N+JE+1 ) = -TEMP2R / TEMP + WORK( 3*N+JE+1 ) = -TEMP2I / TEMP + ELSE + WORK( 2*N+JE+1 ) = ONE + WORK( 3*N+JE+1 ) = ZERO + TEMP = ACOEF*S( JE, JE+1 ) + WORK( 2*N+JE ) = ( BCOEFR*P( JE+1, JE+1 )-ACOEF* + $ S( JE+1, JE+1 ) ) / TEMP + WORK( 3*N+JE ) = BCOEFI*P( JE+1, JE+1 ) / TEMP + END IF + XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), + $ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) ) + END IF +* + DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, 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. +* + DO 160 J = JE + NW, N + IF( IL2BY2 ) THEN + IL2BY2 = .FALSE. + GO TO 160 + END IF +* + NA = 1 + BDIAG( 1 ) = P( J, J ) + IF( J.LT.N ) THEN + IF( S( J+1, J ).NE.ZERO ) THEN + IL2BY2 = .TRUE. + BDIAG( 2 ) = P( J+1, J+1 ) + NA = 2 + END IF + END IF +* +* Check whether scaling is necessary for dot products +* + XSCALE = ONE / MAX( ONE, XMAX ) + TEMP = MAX( WORK( J ), WORK( N+J ), + $ ACOEFA*WORK( J )+BCOEFA*WORK( N+J ) ) + IF( IL2BY2 ) + $ TEMP = MAX( TEMP, WORK( J+1 ), WORK( N+J+1 ), + $ ACOEFA*WORK( J+1 )+BCOEFA*WORK( N+J+1 ) ) + IF( TEMP.GT.BIGNUM*XSCALE ) THEN + DO 90 JW = 0, NW - 1 + DO 80 JR = JE, J - 1 + WORK( ( JW+2 )*N+JR ) = XSCALE* + $ WORK( ( JW+2 )*N+JR ) + 80 CONTINUE + 90 CONTINUE + XMAX = XMAX*XSCALE + END IF +* +* 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=' ' +CDIR$ NEXTSCALAR +C$DIR SCALAR +CDIR$ NEXT SCALAR +CVD$L NOVECTOR +CDEC$ NOVECTOR +CVD$ NOVECTOR +*VDIR NOVECTOR +*VOCL LOOP,SCALAR +CIBM PREFER SCALAR +*$PL$ CMCHAR='*' +* + DO 120 JW = 1, NW +* +*$PL$ CMCHAR=' ' +CDIR$ NEXTSCALAR +C$DIR SCALAR +CDIR$ NEXT SCALAR +CVD$L NOVECTOR +CDEC$ NOVECTOR +CVD$ NOVECTOR +*VDIR NOVECTOR +*VOCL LOOP,SCALAR +CIBM PREFER SCALAR +*$PL$ CMCHAR='*' +* + DO 110 JA = 1, NA + SUMS( JA, JW ) = ZERO + SUMP( JA, JW ) = ZERO +* + DO 100 JR = JE, J - 1 + SUMS( JA, JW ) = SUMS( JA, JW ) + + $ S( JR, J+JA-1 )* + $ WORK( ( JW+1 )*N+JR ) + SUMP( JA, JW ) = SUMP( JA, JW ) + + $ P( JR, J+JA-1 )* + $ WORK( ( JW+1 )*N+JR ) + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE +* +*$PL$ CMCHAR=' ' +CDIR$ NEXTSCALAR +C$DIR SCALAR +CDIR$ NEXT SCALAR +CVD$L NOVECTOR +CDEC$ NOVECTOR +CVD$ NOVECTOR +*VDIR NOVECTOR +*VOCL LOOP,SCALAR +CIBM PREFER SCALAR +*$PL$ CMCHAR='*' +* + DO 130 JA = 1, NA + IF( ILCPLX ) THEN + SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + + $ BCOEFR*SUMP( JA, 1 ) - + $ BCOEFI*SUMP( JA, 2 ) + SUM( JA, 2 ) = -ACOEF*SUMS( JA, 2 ) + + $ BCOEFR*SUMP( JA, 2 ) + + $ BCOEFI*SUMP( JA, 1 ) + ELSE + SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + + $ BCOEFR*SUMP( JA, 1 ) + END IF + 130 CONTINUE +* +* T +* Solve ( a A - b B ) y = SUM(,) +* with scaling and perturbation of the denominator +* + CALL DLALN2( .TRUE., NA, NW, DMIN, ACOEF, S( J, J ), LDS, + $ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR, + $ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP, + $ IINFO ) + IF( SCALE.LT.ONE ) THEN + DO 150 JW = 0, NW - 1 + DO 140 JR = JE, J - 1 + WORK( ( JW+2 )*N+JR ) = SCALE* + $ WORK( ( JW+2 )*N+JR ) + 140 CONTINUE + 150 CONTINUE + XMAX = SCALE*XMAX + END IF + XMAX = MAX( XMAX, TEMP ) + 160 CONTINUE +* +* Copy eigenvector to VL, back transforming if +* HOWMNY='B'. +* + IEIG = IEIG + 1 + IF( ILBACK ) THEN + DO 170 JW = 0, NW - 1 + CALL DGEMV( 'N', N, N+1-JE, ONE, VL( 1, JE ), LDVL, + $ WORK( ( JW+2 )*N+JE ), 1, ZERO, + $ WORK( ( JW+4 )*N+1 ), 1 ) + 170 CONTINUE + CALL DLACPY( ' ', N, NW, WORK( 4*N+1 ), N, VL( 1, JE ), + $ LDVL ) + IBEG = 1 + ELSE + CALL DLACPY( ' ', N, NW, WORK( 2*N+1 ), N, VL( 1, IEIG ), + $ LDVL ) + IBEG = JE + END IF +* +* Scale eigenvector +* + XMAX = ZERO + IF( ILCPLX ) THEN + DO 180 J = IBEG, N + XMAX = MAX( XMAX, ABS( VL( J, IEIG ) )+ + $ ABS( VL( J, IEIG+1 ) ) ) + 180 CONTINUE + ELSE + DO 190 J = IBEG, N + XMAX = MAX( XMAX, ABS( VL( J, IEIG ) ) ) + 190 CONTINUE + END IF +* + IF( XMAX.GT.SAFMIN ) THEN + XSCALE = ONE / XMAX +* + DO 210 JW = 0, NW - 1 + DO 200 JR = IBEG, N + VL( JR, IEIG+JW ) = XSCALE*VL( JR, IEIG+JW ) + 200 CONTINUE + 210 CONTINUE + END IF + IEIG = IEIG + NW - 1 +* + 220 CONTINUE + END IF +* +* Right eigenvectors +* + IF( COMPR ) THEN + IEIG = IM + 1 +* +* Main loop over eigenvalues +* + ILCPLX = .FALSE. + DO 500 JE = N, 1, -1 +* +* 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 ) THEN + ILCPLX = .FALSE. + GO TO 500 + END IF + NW = 1 + IF( JE.GT.1 ) THEN + IF( S( JE, JE-1 ).NE.ZERO ) THEN + ILCPLX = .TRUE. + NW = 2 + END IF + END IF + IF( ILALL ) THEN + ILCOMP = .TRUE. + ELSE IF( ILCPLX ) THEN + ILCOMP = SELECT( JE ) .OR. SELECT( JE-1 ) + ELSE + ILCOMP = SELECT( JE ) + END IF + IF( .NOT.ILCOMP ) + $ GO TO 500 +* +* Decide if (a) singular pencil, (b) real eigenvalue, or +* (c) complex eigenvalue. +* + IF( .NOT.ILCPLX ) THEN + IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN +* +* Singular matrix pencil -- unit eigenvector +* + IEIG = IEIG - 1 + DO 230 JR = 1, N + VR( JR, IEIG ) = ZERO + 230 CONTINUE + VR( IEIG, IEIG ) = ONE + GO TO 500 + END IF + END IF +* +* Clear vector +* + DO 250 JW = 0, NW - 1 + DO 240 JR = 1, N + WORK( ( JW+2 )*N+JR ) = ZERO + 240 CONTINUE + 250 CONTINUE +* +* Compute coefficients in ( a A - b B ) x = 0 +* a is ACOEF +* b is BCOEFR + i*BCOEFI +* + IF( .NOT.ILCPLX ) THEN +* +* Real eigenvalue +* + TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, + $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) + SALFAR = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*P( JE, JE ) )*BSCALE + ACOEF = SBETA*ASCALE + BCOEFR = SALFAR*BSCALE + BCOEFI = ZERO +* +* Scale to avoid underflow +* + SCALE = ONE + LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL + LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT. + $ SMALL + IF( LSA ) + $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) + IF( LSB ) + $ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )* + $ MIN( BNORM, BIG ) ) + IF( LSA .OR. LSB ) THEN + SCALE = MIN( SCALE, ONE / + $ ( SAFMIN*MAX( ONE, ABS( ACOEF ), + $ ABS( BCOEFR ) ) ) ) + IF( LSA ) THEN + ACOEF = ASCALE*( SCALE*SBETA ) + ELSE + ACOEF = SCALE*ACOEF + END IF + IF( LSB ) THEN + BCOEFR = BSCALE*( SCALE*SALFAR ) + ELSE + BCOEFR = SCALE*BCOEFR + END IF + END IF + ACOEFA = ABS( ACOEF ) + BCOEFA = ABS( BCOEFR ) +* +* First component is 1 +* + WORK( 2*N+JE ) = ONE + XMAX = ONE +* +* Compute contribution from column JE of A and B to sum +* (See "Further Details", above.) +* + DO 260 JR = 1, JE - 1 + WORK( 2*N+JR ) = BCOEFR*P( JR, JE ) - + $ ACOEF*S( JR, JE ) + 260 CONTINUE + ELSE +* +* Complex eigenvalue +* + CALL DLAG2( S( JE-1, JE-1 ), LDS, P( JE-1, JE-1 ), LDP, + $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, + $ BCOEFI ) + IF( BCOEFI.EQ.ZERO ) THEN + INFO = JE - 1 + RETURN + END IF +* +* Scale to avoid over/underflow +* + ACOEFA = ABS( ACOEF ) + BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI ) + SCALE = ONE + IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN ) + $ SCALE = ( SAFMIN / ULP ) / ACOEFA + IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN ) + $ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA ) + IF( SAFMIN*ACOEFA.GT.ASCALE ) + $ SCALE = ASCALE / ( SAFMIN*ACOEFA ) + IF( SAFMIN*BCOEFA.GT.BSCALE ) + $ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) ) + IF( SCALE.NE.ONE ) THEN + ACOEF = SCALE*ACOEF + ACOEFA = ABS( ACOEF ) + BCOEFR = SCALE*BCOEFR + BCOEFI = SCALE*BCOEFI + BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI ) + END IF +* +* Compute first two components of eigenvector +* and contribution to sums +* + TEMP = ACOEF*S( JE, JE-1 ) + TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) + TEMP2I = -BCOEFI*P( JE, JE ) + IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN + WORK( 2*N+JE ) = ONE + WORK( 3*N+JE ) = ZERO + WORK( 2*N+JE-1 ) = -TEMP2R / TEMP + WORK( 3*N+JE-1 ) = -TEMP2I / TEMP + ELSE + WORK( 2*N+JE-1 ) = ONE + WORK( 3*N+JE-1 ) = ZERO + TEMP = ACOEF*S( JE-1, JE ) + WORK( 2*N+JE ) = ( BCOEFR*P( JE-1, JE-1 )-ACOEF* + $ S( JE-1, JE-1 ) ) / TEMP + WORK( 3*N+JE ) = BCOEFI*P( JE-1, JE-1 ) / TEMP + END IF +* + XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), + $ ABS( WORK( 2*N+JE-1 ) )+ABS( WORK( 3*N+JE-1 ) ) ) +* +* Compute contribution from columns JE and JE-1 +* of A and B to the sums. +* + CREALA = ACOEF*WORK( 2*N+JE-1 ) + CIMAGA = ACOEF*WORK( 3*N+JE-1 ) + CREALB = BCOEFR*WORK( 2*N+JE-1 ) - + $ BCOEFI*WORK( 3*N+JE-1 ) + CIMAGB = BCOEFI*WORK( 2*N+JE-1 ) + + $ BCOEFR*WORK( 3*N+JE-1 ) + CRE2A = ACOEF*WORK( 2*N+JE ) + CIM2A = ACOEF*WORK( 3*N+JE ) + CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE ) + CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE ) + DO 270 JR = 1, JE - 2 + WORK( 2*N+JR ) = -CREALA*S( JR, JE-1 ) + + $ CREALB*P( JR, JE-1 ) - + $ CRE2A*S( JR, JE ) + CRE2B*P( JR, JE ) + WORK( 3*N+JR ) = -CIMAGA*S( JR, JE-1 ) + + $ CIMAGB*P( JR, JE-1 ) - + $ CIM2A*S( JR, JE ) + CIM2B*P( JR, JE ) + 270 CONTINUE + END IF +* + DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN ) +* +* Columnwise triangular solve of (a A - b B) x = 0 +* + IL2BY2 = .FALSE. + DO 370 J = JE - NW, 1, -1 +* +* 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( .NOT.IL2BY2 .AND. J.GT.1 ) THEN + IF( S( J, J-1 ).NE.ZERO ) THEN + IL2BY2 = .TRUE. + GO TO 370 + END IF + END IF + BDIAG( 1 ) = P( J, J ) + IF( IL2BY2 ) THEN + NA = 2 + BDIAG( 2 ) = P( J+1, J+1 ) + ELSE + NA = 1 + END IF +* +* Compute x(j) (and x(j+1), if 2-by-2 block) +* + CALL DLALN2( .FALSE., NA, NW, DMIN, ACOEF, S( J, J ), + $ LDS, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), + $ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP, + $ IINFO ) + IF( SCALE.LT.ONE ) THEN +* + DO 290 JW = 0, NW - 1 + DO 280 JR = 1, JE + WORK( ( JW+2 )*N+JR ) = SCALE* + $ WORK( ( JW+2 )*N+JR ) + 280 CONTINUE + 290 CONTINUE + END IF + XMAX = MAX( SCALE*XMAX, TEMP ) +* + DO 310 JW = 1, NW + DO 300 JA = 1, NA + WORK( ( JW+1 )*N+J+JA-1 ) = SUM( JA, JW ) + 300 CONTINUE + 310 CONTINUE +* +* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling +* + IF( J.GT.1 ) THEN +* +* Check whether scaling is necessary for sum. +* + XSCALE = ONE / MAX( ONE, XMAX ) + TEMP = ACOEFA*WORK( J ) + BCOEFA*WORK( N+J ) + IF( IL2BY2 ) + $ TEMP = MAX( TEMP, ACOEFA*WORK( J+1 )+BCOEFA* + $ WORK( N+J+1 ) ) + TEMP = MAX( TEMP, ACOEFA, BCOEFA ) + IF( TEMP.GT.BIGNUM*XSCALE ) THEN +* + DO 330 JW = 0, NW - 1 + DO 320 JR = 1, JE + WORK( ( JW+2 )*N+JR ) = XSCALE* + $ WORK( ( JW+2 )*N+JR ) + 320 CONTINUE + 330 CONTINUE + XMAX = XMAX*XSCALE + END IF +* +* 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. +* +* + DO 360 JA = 1, NA + IF( ILCPLX ) THEN + CREALA = ACOEF*WORK( 2*N+J+JA-1 ) + CIMAGA = ACOEF*WORK( 3*N+J+JA-1 ) + CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) - + $ BCOEFI*WORK( 3*N+J+JA-1 ) + CIMAGB = BCOEFI*WORK( 2*N+J+JA-1 ) + + $ BCOEFR*WORK( 3*N+J+JA-1 ) + DO 340 JR = 1, J - 1 + WORK( 2*N+JR ) = WORK( 2*N+JR ) - + $ CREALA*S( JR, J+JA-1 ) + + $ CREALB*P( JR, J+JA-1 ) + WORK( 3*N+JR ) = WORK( 3*N+JR ) - + $ CIMAGA*S( JR, J+JA-1 ) + + $ CIMAGB*P( JR, J+JA-1 ) + 340 CONTINUE + ELSE + CREALA = ACOEF*WORK( 2*N+J+JA-1 ) + CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) + DO 350 JR = 1, J - 1 + WORK( 2*N+JR ) = WORK( 2*N+JR ) - + $ CREALA*S( JR, J+JA-1 ) + + $ CREALB*P( JR, J+JA-1 ) + 350 CONTINUE + END IF + 360 CONTINUE + END IF +* + IL2BY2 = .FALSE. + 370 CONTINUE +* +* Copy eigenvector to VR, back transforming if +* HOWMNY='B'. +* + IEIG = IEIG - NW + IF( ILBACK ) THEN +* + DO 410 JW = 0, NW - 1 + DO 380 JR = 1, N + WORK( ( JW+4 )*N+JR ) = WORK( ( JW+2 )*N+1 )* + $ VR( JR, 1 ) + 380 CONTINUE +* +* A series of compiler directives to defeat +* vectorization for the next loop +* +* + DO 400 JC = 2, JE + DO 390 JR = 1, N + WORK( ( JW+4 )*N+JR ) = WORK( ( JW+4 )*N+JR ) + + $ WORK( ( JW+2 )*N+JC )*VR( JR, JC ) + 390 CONTINUE + 400 CONTINUE + 410 CONTINUE +* + DO 430 JW = 0, NW - 1 + DO 420 JR = 1, N + VR( JR, IEIG+JW ) = WORK( ( JW+4 )*N+JR ) + 420 CONTINUE + 430 CONTINUE +* + IEND = N + ELSE + DO 450 JW = 0, NW - 1 + DO 440 JR = 1, N + VR( JR, IEIG+JW ) = WORK( ( JW+2 )*N+JR ) + 440 CONTINUE + 450 CONTINUE +* + IEND = JE + END IF +* +* Scale eigenvector +* + XMAX = ZERO + IF( ILCPLX ) THEN + DO 460 J = 1, IEND + XMAX = MAX( XMAX, ABS( VR( J, IEIG ) )+ + $ ABS( VR( J, IEIG+1 ) ) ) + 460 CONTINUE + ELSE + DO 470 J = 1, IEND + XMAX = MAX( XMAX, ABS( VR( J, IEIG ) ) ) + 470 CONTINUE + END IF +* + IF( XMAX.GT.SAFMIN ) THEN + XSCALE = ONE / XMAX + DO 490 JW = 0, NW - 1 + DO 480 JR = 1, IEND + VR( JR, IEIG+JW ) = XSCALE*VR( JR, IEIG+JW ) + 480 CONTINUE + 490 CONTINUE + END IF + 500 CONTINUE + END IF +* + RETURN +* +* End of DTGEVC +* + END diff --git a/2.3-1/src/fortran/lapack/dtgex2.f b/2.3-1/src/fortran/lapack/dtgex2.f new file mode 100644 index 00000000..8351b7fd --- /dev/null +++ b/2.3-1/src/fortran/lapack/dtgex2.f @@ -0,0 +1,581 @@ + SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, + $ LDZ, J1, N1, N2, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL WANTQ, WANTZ + INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2 +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), + $ WORK( * ), Z( LDZ, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION TEN + PARAMETER ( TEN = 1.0D+01 ) + INTEGER LDST + PARAMETER ( LDST = 4 ) + LOGICAL WANDS + PARAMETER ( WANDS = .TRUE. ) +* .. +* .. Local Scalars .. + LOGICAL DTRONG, WEAK + INTEGER I, IDUM, LINFO, M + DOUBLE PRECISION BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS, + $ F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS +* .. +* .. Local Arrays .. + INTEGER IWORK( LDST ) + DOUBLE PRECISION AI( 2 ), AR( 2 ), BE( 2 ), IR( LDST, LDST ), + $ IRCOP( LDST, LDST ), LI( LDST, LDST ), + $ LICOP( LDST, LDST ), S( LDST, LDST ), + $ SCPY( LDST, LDST ), T( LDST, LDST ), + $ TAUL( LDST ), TAUR( LDST ), TCPY( LDST, LDST ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGEQR2, DGERQ2, DLACPY, DLAGV2, DLARTG, + $ DLASET, DLASSQ, DORG2R, DORGR2, DORM2R, DORMR2, + $ DROT, DSCAL, DTGSY2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Quick return if possible +* + IF( N.LE.1 .OR. N1.LE.0 .OR. N2.LE.0 ) + $ RETURN + IF( N1.GT.N .OR. ( J1+N1 ).GT.N ) + $ RETURN + M = N1 + N2 + IF( LWORK.LT.MAX( 1, N*M, M*M*2 ) ) THEN + INFO = -16 + WORK( 1 ) = MAX( 1, N*M, M*M*2 ) + RETURN + END IF +* + WEAK = .FALSE. + DTRONG = .FALSE. +* +* Make a local copy of selected block +* + CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, LI, LDST ) + CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, IR, LDST ) + CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST ) + CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST ) +* +* Compute threshold for testing acceptance of swapping. +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + DSCALE = ZERO + DSUM = ONE + CALL DLACPY( 'Full', M, M, S, LDST, WORK, M ) + CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM ) + CALL DLACPY( 'Full', M, M, T, LDST, WORK, M ) + CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM ) + DNORM = DSCALE*SQRT( DSUM ) + THRESH = MAX( TEN*EPS*DNORM, SMLNUM ) +* + IF( M.EQ.2 ) THEN +* +* 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( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 ) + G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 ) + SB = ABS( T( 2, 2 ) ) + SA = ABS( S( 2, 2 ) ) + CALL DLARTG( F, G, IR( 1, 2 ), IR( 1, 1 ), DDUM ) + IR( 2, 1 ) = -IR( 1, 2 ) + IR( 2, 2 ) = IR( 1, 1 ) + CALL DROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, IR( 1, 1 ), + $ IR( 2, 1 ) ) + CALL DROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, IR( 1, 1 ), + $ IR( 2, 1 ) ) + IF( SA.GE.SB ) THEN + CALL DLARTG( S( 1, 1 ), S( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ), + $ DDUM ) + ELSE + CALL DLARTG( T( 1, 1 ), T( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ), + $ DDUM ) + END IF + CALL DROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, LI( 1, 1 ), + $ LI( 2, 1 ) ) + CALL DROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, LI( 1, 1 ), + $ LI( 2, 1 ) ) + LI( 2, 2 ) = LI( 1, 1 ) + LI( 1, 2 ) = -LI( 2, 1 ) +* +* Weak stability test: +* |S21| + |T21| <= O(EPS * F-norm((S, T))) +* + WS = ABS( S( 2, 1 ) ) + ABS( T( 2, 1 ) ) + WEAK = WS.LE.THRESH + IF( .NOT.WEAK ) + $ GO TO 70 +* + IF( WANDS ) THEN +* +* Strong stability test: +* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B))) +* + CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ), + $ M ) + CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO, + $ WORK, M ) + CALL DGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE, + $ WORK( M*M+1 ), M ) + DSCALE = ZERO + DSUM = ONE + CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM ) +* + CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ), + $ M ) + CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO, + $ WORK, M ) + CALL DGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE, + $ WORK( M*M+1 ), M ) + CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM ) + SS = DSCALE*SQRT( DSUM ) + DTRONG = SS.LE.THRESH + IF( .NOT.DTRONG ) + $ GO TO 70 + END IF +* +* 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)). +* + CALL DROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, IR( 1, 1 ), + $ IR( 2, 1 ) ) + CALL DROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, IR( 1, 1 ), + $ IR( 2, 1 ) ) + CALL DROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA, + $ LI( 1, 1 ), LI( 2, 1 ) ) + CALL DROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB, + $ LI( 1, 1 ), LI( 2, 1 ) ) +* +* Set N1-by-N2 (2,1) - blocks to ZERO. +* + A( J1+1, J1 ) = ZERO + B( J1+1, J1 ) = ZERO +* +* Accumulate transformations into Q and Z if requested. +* + IF( WANTZ ) + $ CALL DROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, IR( 1, 1 ), + $ IR( 2, 1 ) ) + IF( WANTQ ) + $ CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, LI( 1, 1 ), + $ LI( 2, 1 ) ) +* +* Exit with INFO = 0 if swap was successfully performed. +* + RETURN +* + 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. +* + CALL DLACPY( 'Full', N1, N2, T( 1, N1+1 ), LDST, LI, LDST ) + CALL DLACPY( 'Full', N1, N2, S( 1, N1+1 ), LDST, + $ IR( N2+1, N1+1 ), LDST ) + CALL DTGSY2( 'N', 0, N1, N2, S, LDST, S( N1+1, N1+1 ), LDST, + $ IR( N2+1, N1+1 ), LDST, T, LDST, T( N1+1, N1+1 ), + $ LDST, LI, LDST, SCALE, DSUM, DSCALE, IWORK, IDUM, + $ LINFO ) +* +* Compute orthogonal matrix QL: +* +* QL' * LI = [ TL ] +* [ 0 ] +* where +* LI = [ -L ] +* [ SCALE * identity(N2) ] +* + DO 10 I = 1, N2 + CALL DSCAL( N1, -ONE, LI( 1, I ), 1 ) + LI( N1+I, I ) = SCALE + 10 CONTINUE + CALL DGEQR2( M, N2, LI, LDST, TAUL, WORK, LINFO ) + IF( LINFO.NE.0 ) + $ GO TO 70 + CALL DORG2R( M, M, N2, LI, LDST, TAUL, WORK, LINFO ) + IF( LINFO.NE.0 ) + $ GO TO 70 +* +* Compute orthogonal matrix RQ: +* +* IR * RQ' = [ 0 TR], +* +* where IR = [ SCALE * identity(N1), R ] +* + DO 20 I = 1, N1 + IR( N2+I, I ) = SCALE + 20 CONTINUE + CALL DGERQ2( N1, M, IR( N2+1, 1 ), LDST, TAUR, WORK, LINFO ) + IF( LINFO.NE.0 ) + $ GO TO 70 + CALL DORGR2( M, M, N1, IR, LDST, TAUR, WORK, LINFO ) + IF( LINFO.NE.0 ) + $ GO TO 70 +* +* Perform the swapping tentatively: +* + CALL DGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO, + $ WORK, M ) + CALL DGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, S, + $ LDST ) + CALL DGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO, + $ WORK, M ) + CALL DGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, T, + $ LDST ) + CALL DLACPY( 'F', M, M, S, LDST, SCPY, LDST ) + CALL DLACPY( 'F', M, M, T, LDST, TCPY, LDST ) + CALL DLACPY( 'F', M, M, IR, LDST, IRCOP, LDST ) + CALL DLACPY( 'F', M, M, LI, LDST, LICOP, LDST ) +* +* Triangularize the B-part by an RQ factorization. +* Apply transformation (from left) to A-part, giving S. +* + CALL DGERQ2( M, M, T, LDST, TAUR, WORK, LINFO ) + IF( LINFO.NE.0 ) + $ GO TO 70 + CALL DORMR2( 'R', 'T', M, M, M, T, LDST, TAUR, S, LDST, WORK, + $ LINFO ) + IF( LINFO.NE.0 ) + $ GO TO 70 + CALL DORMR2( 'L', 'N', M, M, M, T, LDST, TAUR, IR, LDST, WORK, + $ LINFO ) + IF( LINFO.NE.0 ) + $ GO TO 70 +* +* Compute F-norm(S21) in BRQA21. (T21 is 0.) +* + DSCALE = ZERO + DSUM = ONE + DO 30 I = 1, N2 + CALL DLASSQ( N1, S( N2+1, I ), 1, DSCALE, DSUM ) + 30 CONTINUE + BRQA21 = DSCALE*SQRT( DSUM ) +* +* Triangularize the B-part by a QR factorization. +* Apply transformation (from right) to A-part, giving S. +* + CALL DGEQR2( M, M, TCPY, LDST, TAUL, WORK, LINFO ) + IF( LINFO.NE.0 ) + $ GO TO 70 + CALL DORM2R( 'L', 'T', M, M, M, TCPY, LDST, TAUL, SCPY, LDST, + $ WORK, INFO ) + CALL DORM2R( 'R', 'N', M, M, M, TCPY, LDST, TAUL, LICOP, LDST, + $ WORK, INFO ) + IF( LINFO.NE.0 ) + $ GO TO 70 +* +* Compute F-norm(S21) in BQRA21. (T21 is 0.) +* + DSCALE = ZERO + DSUM = ONE + DO 40 I = 1, N2 + CALL DLASSQ( N1, SCPY( N2+1, I ), 1, DSCALE, DSUM ) + 40 CONTINUE + BQRA21 = DSCALE*SQRT( DSUM ) +* +* Decide which method to use. +* Weak stability test: +* F-norm(S21) <= O(EPS * F-norm((S, T))) +* + IF( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESH ) THEN + CALL DLACPY( 'F', M, M, SCPY, LDST, S, LDST ) + CALL DLACPY( 'F', M, M, TCPY, LDST, T, LDST ) + CALL DLACPY( 'F', M, M, IRCOP, LDST, IR, LDST ) + CALL DLACPY( 'F', M, M, LICOP, LDST, LI, LDST ) + ELSE IF( BRQA21.GE.THRESH ) THEN + GO TO 70 + END IF +* +* Set lower triangle of B-part to zero +* + CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, T(2,1), LDST ) +* + IF( WANDS ) THEN +* +* Strong stability test: +* F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B))) +* + CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ), + $ M ) + CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO, + $ WORK, M ) + CALL DGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE, + $ WORK( M*M+1 ), M ) + DSCALE = ZERO + DSUM = ONE + CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM ) +* + CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ), + $ M ) + CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO, + $ WORK, M ) + CALL DGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE, + $ WORK( M*M+1 ), M ) + CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM ) + SS = DSCALE*SQRT( DSUM ) + DTRONG = ( SS.LE.THRESH ) + IF( .NOT.DTRONG ) + $ GO TO 70 +* + END IF +* +* If the swap is accepted ("weakly" and "strongly"), apply the +* transformations and set N1-by-N2 (2,1)-block to zero. +* + CALL DLASET( 'Full', N1, N2, ZERO, ZERO, S(N2+1,1), LDST ) +* +* copy back M-by-M diagonal block starting at index J1 of (A, B) +* + CALL DLACPY( 'F', M, M, S, LDST, A( J1, J1 ), LDA ) + CALL DLACPY( 'F', M, M, T, LDST, B( J1, J1 ), LDB ) + CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, T, LDST ) +* +* Standardize existing 2-by-2 blocks. +* + DO 50 I = 1, M*M + WORK(I) = ZERO + 50 CONTINUE + WORK( 1 ) = ONE + T( 1, 1 ) = ONE + IDUM = LWORK - M*M - 2 + IF( N2.GT.1 ) THEN + CALL DLAGV2( A( J1, J1 ), LDA, B( J1, J1 ), LDB, AR, AI, BE, + $ WORK( 1 ), WORK( 2 ), T( 1, 1 ), T( 2, 1 ) ) + WORK( M+1 ) = -WORK( 2 ) + WORK( M+2 ) = WORK( 1 ) + T( N2, N2 ) = T( 1, 1 ) + T( 1, 2 ) = -T( 2, 1 ) + END IF + WORK( M*M ) = ONE + T( M, M ) = ONE +* + IF( N1.GT.1 ) THEN + CALL DLAGV2( A( J1+N2, J1+N2 ), LDA, B( J1+N2, J1+N2 ), LDB, + $ TAUR, TAUL, WORK( M*M+1 ), WORK( N2*M+N2+1 ), + $ WORK( N2*M+N2+2 ), T( N2+1, N2+1 ), + $ T( M, M-1 ) ) + WORK( M*M ) = WORK( N2*M+N2+1 ) + WORK( M*M-1 ) = -WORK( N2*M+N2+2 ) + T( M, M ) = T( N2+1, N2+1 ) + T( M-1, M ) = -T( M, M-1 ) + END IF + CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, A( J1, J1+N2 ), + $ LDA, ZERO, WORK( M*M+1 ), N2 ) + CALL DLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, A( J1, J1+N2 ), + $ LDA ) + CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, B( J1, J1+N2 ), + $ LDB, ZERO, WORK( M*M+1 ), N2 ) + CALL DLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, B( J1, J1+N2 ), + $ LDB ) + CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, WORK, M, ZERO, + $ WORK( M*M+1 ), M ) + CALL DLACPY( 'Full', M, M, WORK( M*M+1 ), M, LI, LDST ) + CALL DGEMM( 'N', 'N', N2, N1, N1, ONE, A( J1, J1+N2 ), LDA, + $ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 ) + CALL DLACPY( 'Full', N2, N1, WORK, N2, A( J1, J1+N2 ), LDA ) + CALL DGEMM( 'N', 'N', N2, N1, N1, ONE, B( J1, J1+N2 ), LDB, + $ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 ) + CALL DLACPY( 'Full', N2, N1, WORK, N2, B( J1, J1+N2 ), LDB ) + CALL DGEMM( 'T', 'N', M, M, M, ONE, IR, LDST, T, LDST, ZERO, + $ WORK, M ) + CALL DLACPY( 'Full', M, M, WORK, M, IR, LDST ) +* +* Accumulate transformations into Q and Z if requested. +* + IF( WANTQ ) THEN + CALL DGEMM( 'N', 'N', N, M, M, ONE, Q( 1, J1 ), LDQ, LI, + $ LDST, ZERO, WORK, N ) + CALL DLACPY( 'Full', N, M, WORK, N, Q( 1, J1 ), LDQ ) +* + END IF +* + IF( WANTZ ) THEN + CALL DGEMM( 'N', 'N', N, M, M, ONE, Z( 1, J1 ), LDZ, IR, + $ LDST, ZERO, WORK, N ) + CALL DLACPY( 'Full', N, M, WORK, N, Z( 1, J1 ), LDZ ) +* + END IF +* +* 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.LE.N ) THEN + CALL DGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST, + $ A( J1, I ), LDA, ZERO, WORK, M ) + CALL DLACPY( 'Full', M, N-I+1, WORK, M, A( J1, I ), LDA ) + CALL DGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST, + $ B( J1, I ), LDA, ZERO, WORK, M ) + CALL DLACPY( 'Full', M, N-I+1, WORK, M, B( J1, I ), LDB ) + END IF + I = J1 - 1 + IF( I.GT.0 ) THEN + CALL DGEMM( 'N', 'N', I, M, M, ONE, A( 1, J1 ), LDA, IR, + $ LDST, ZERO, WORK, I ) + CALL DLACPY( 'Full', I, M, WORK, I, A( 1, J1 ), LDA ) + CALL DGEMM( 'N', 'N', I, M, M, ONE, B( 1, J1 ), LDB, IR, + $ LDST, ZERO, WORK, I ) + CALL DLACPY( 'Full', I, M, WORK, I, B( 1, J1 ), LDB ) + END IF +* +* Exit with INFO = 0 if swap was successfully performed. +* + RETURN +* + END IF +* +* Exit with INFO = 1 if swap was rejected. +* + 70 CONTINUE +* + INFO = 1 + RETURN +* +* End of DTGEX2 +* + END diff --git a/2.3-1/src/fortran/lapack/dtgexc.f b/2.3-1/src/fortran/lapack/dtgexc.f new file mode 100644 index 00000000..bafefea2 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dtgexc.f @@ -0,0 +1,440 @@ + SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, + $ LDZ, IFST, ILST, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL WANTQ, WANTZ + INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), + $ WORK( * ), Z( LDZ, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER HERE, LWMIN, NBF, NBL, NBNEXT +* .. +* .. External Subroutines .. + EXTERNAL DTGEX2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Decode and test input arguments. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. ( LDQ.LT.MAX( 1, N ) ) ) THEN + INFO = -9 + ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. ( LDZ.LT.MAX( 1, N ) ) ) THEN + INFO = -11 + ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN + INFO = -12 + ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + ELSE + LWMIN = 4*N + 16 + END IF + WORK(1) = LWMIN +* + IF (LWORK.LT.LWMIN .AND. .NOT.LQUERY) THEN + INFO = -15 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTGEXC', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* +* Determine the first row of the specified block and find out +* if it is 1-by-1 or 2-by-2. +* + IF( IFST.GT.1 ) THEN + IF( A( IFST, IFST-1 ).NE.ZERO ) + $ IFST = IFST - 1 + END IF + NBF = 1 + IF( IFST.LT.N ) THEN + IF( A( IFST+1, IFST ).NE.ZERO ) + $ NBF = 2 + END IF +* +* Determine the first row of the final block +* and find out if it is 1-by-1 or 2-by-2. +* + IF( ILST.GT.1 ) THEN + IF( A( ILST, ILST-1 ).NE.ZERO ) + $ ILST = ILST - 1 + END IF + NBL = 1 + IF( ILST.LT.N ) THEN + IF( A( ILST+1, ILST ).NE.ZERO ) + $ NBL = 2 + END IF + IF( IFST.EQ.ILST ) + $ RETURN +* + IF( IFST.LT.ILST ) THEN +* +* Update ILST. +* + IF( NBF.EQ.2 .AND. NBL.EQ.1 ) + $ ILST = ILST - 1 + IF( NBF.EQ.1 .AND. NBL.EQ.2 ) + $ ILST = ILST + 1 +* + HERE = IFST +* + 10 CONTINUE +* +* Swap with next one below. +* + IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN +* +* Current block either 1-by-1 or 2-by-2. +* + NBNEXT = 1 + IF( HERE+NBF+1.LE.N ) THEN + IF( A( HERE+NBF+1, HERE+NBF ).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, + $ LDZ, HERE, NBF, NBNEXT, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE + NBNEXT +* +* Test if 2-by-2 block breaks into two 1-by-1 blocks. +* + IF( NBF.EQ.2 ) THEN + IF( A( HERE+1, HERE ).EQ.ZERO ) + $ NBF = 3 + END IF +* + ELSE +* +* Current block consists of two 1-by-1 blocks, each of which +* must be swapped individually. +* + NBNEXT = 1 + IF( HERE+3.LE.N ) THEN + IF( A( HERE+3, HERE+2 ).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, + $ LDZ, HERE+1, 1, NBNEXT, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + IF( NBNEXT.EQ.1 ) THEN +* +* Swap two 1-by-1 blocks. +* + CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, + $ LDZ, HERE, 1, 1, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE + 1 +* + ELSE +* +* Recompute NBNEXT in case of 2-by-2 split. +* + IF( A( HERE+2, HERE+1 ).EQ.ZERO ) + $ NBNEXT = 1 + IF( NBNEXT.EQ.2 ) THEN +* +* 2-by-2 block did not split. +* + CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, + $ Z, LDZ, HERE, 1, NBNEXT, WORK, LWORK, + $ INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE + 2 + ELSE +* +* 2-by-2 block did split. +* + CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, + $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE + 1 + CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, + $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE + 1 + END IF +* + END IF + END IF + IF( HERE.LT.ILST ) + $ GO TO 10 + ELSE + HERE = IFST +* + 20 CONTINUE +* +* Swap with next one below. +* + IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN +* +* Current block either 1-by-1 or 2-by-2. +* + NBNEXT = 1 + IF( HERE.GE.3 ) THEN + IF( A( HERE-1, HERE-2 ).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, + $ LDZ, HERE-NBNEXT, NBNEXT, NBF, WORK, LWORK, + $ INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE - NBNEXT +* +* Test if 2-by-2 block breaks into two 1-by-1 blocks. +* + IF( NBF.EQ.2 ) THEN + IF( A( HERE+1, HERE ).EQ.ZERO ) + $ NBF = 3 + END IF +* + ELSE +* +* Current block consists of two 1-by-1 blocks, each of which +* must be swapped individually. +* + NBNEXT = 1 + IF( HERE.GE.3 ) THEN + IF( A( HERE-1, HERE-2 ).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, + $ LDZ, HERE-NBNEXT, NBNEXT, 1, WORK, LWORK, + $ INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + IF( NBNEXT.EQ.1 ) THEN +* +* Swap two 1-by-1 blocks. +* + CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, + $ LDZ, HERE, NBNEXT, 1, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE - 1 + ELSE +* +* Recompute NBNEXT in case of 2-by-2 split. +* + IF( A( HERE, HERE-1 ).EQ.ZERO ) + $ NBNEXT = 1 + IF( NBNEXT.EQ.2 ) THEN +* +* 2-by-2 block did not split. +* + CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, + $ Z, LDZ, HERE-1, 2, 1, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE - 2 + ELSE +* +* 2-by-2 block did split. +* + CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, + $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE - 1 + CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, + $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE - 1 + END IF + END IF + END IF + IF( HERE.GT.ILST ) + $ GO TO 20 + END IF + ILST = HERE + WORK( 1 ) = LWMIN + RETURN +* +* End of DTGEXC +* + END diff --git a/2.3-1/src/fortran/lapack/dtgsen.f b/2.3-1/src/fortran/lapack/dtgsen.f new file mode 100644 index 00000000..917a7b0f --- /dev/null +++ b/2.3-1/src/fortran/lapack/dtgsen.f @@ -0,0 +1,723 @@ + SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, + $ PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* 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 .. + LOGICAL WANTQ, WANTZ + INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, + $ M, N + DOUBLE PRECISION PL, PR +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), + $ B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ), + $ WORK( * ), Z( LDZ, * ) +* .. +* +* 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)) +* 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 >= 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 .. + INTEGER IDIFJB + PARAMETER ( IDIFJB = 3 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, PAIR, SWAP, WANTD, WANTD1, WANTD2, + $ WANTP + INTEGER I, IERR, IJB, K, KASE, KK, KS, LIWMIN, LWMIN, + $ MN2, N1, N2 + DOUBLE PRECISION DSCALE, DSUM, EPS, RDSCAL, SMLNUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DLACPY, DLAG2, DLASSQ, DTGEXC, DTGSYL, + $ XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN + INFO = -14 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -16 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTGSEN', -INFO ) + RETURN + END IF +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + IERR = 0 +* + WANTP = IJOB.EQ.1 .OR. IJOB.GE.4 + WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4 + WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5 + WANTD = WANTD1 .OR. WANTD2 +* +* Set M to the dimension of the specified pair of deflating +* subspaces. +* + M = 0 + PAIR = .FALSE. + DO 10 K = 1, N + IF( PAIR ) THEN + PAIR = .FALSE. + ELSE + IF( K.LT.N ) THEN + IF( A( K+1, K ).EQ.ZERO ) THEN + IF( SELECT( K ) ) + $ M = M + 1 + ELSE + PAIR = .TRUE. + IF( SELECT( K ) .OR. SELECT( K+1 ) ) + $ M = M + 2 + END IF + ELSE + IF( SELECT( N ) ) + $ M = M + 1 + END IF + END IF + 10 CONTINUE +* + IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN + LWMIN = MAX( 1, 4*N+16, 2*M*( N-M ) ) + LIWMIN = MAX( 1, N+6 ) + ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN + LWMIN = MAX( 1, 4*N+16, 4*M*( N-M ) ) + LIWMIN = MAX( 1, 2*M*( N-M ), N+6 ) + ELSE + LWMIN = MAX( 1, 4*N+16 ) + LIWMIN = 1 + END IF +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -22 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -24 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTGSEN', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible. +* + IF( M.EQ.N .OR. M.EQ.0 ) THEN + IF( WANTP ) THEN + PL = ONE + PR = ONE + END IF + IF( WANTD ) THEN + DSCALE = ZERO + DSUM = ONE + DO 20 I = 1, N + CALL DLASSQ( N, A( 1, I ), 1, DSCALE, DSUM ) + CALL DLASSQ( N, B( 1, I ), 1, DSCALE, DSUM ) + 20 CONTINUE + DIF( 1 ) = DSCALE*SQRT( DSUM ) + DIF( 2 ) = DIF( 1 ) + END IF + GO TO 60 + END IF +* +* Collect the selected blocks at the top-left corner of (A, B). +* + KS = 0 + PAIR = .FALSE. + DO 30 K = 1, N + IF( PAIR ) THEN + PAIR = .FALSE. + ELSE +* + SWAP = SELECT( K ) + IF( K.LT.N ) THEN + IF( A( K+1, K ).NE.ZERO ) THEN + PAIR = .TRUE. + SWAP = SWAP .OR. SELECT( K+1 ) + END IF + END IF +* + IF( SWAP ) THEN + KS = KS + 1 +* +* 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.NE.KS ) + $ CALL DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, + $ Z, LDZ, KK, KS, WORK, LWORK, IERR ) +* + IF( IERR.GT.0 ) THEN +* +* Swap is rejected: exit. +* + INFO = 1 + IF( WANTP ) THEN + PL = ZERO + PR = ZERO + END IF + IF( WANTD ) THEN + DIF( 1 ) = ZERO + DIF( 2 ) = ZERO + END IF + GO TO 60 + END IF +* + IF( PAIR ) + $ KS = KS + 1 + END IF + END IF + 30 CONTINUE + IF( WANTP ) THEN +* +* Solve generalized Sylvester equation for R and L +* and compute PL and PR. +* + N1 = M + N2 = N - M + I = N1 + 1 + IJB = 0 + CALL DLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 ) + CALL DLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ), + $ N1 ) + CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, + $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1, + $ DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), + $ LWORK-2*N1*N2, IWORK, IERR ) +* +* Estimate the reciprocal of norms of "projections" onto left +* and right eigenspaces. +* + RDSCAL = ZERO + DSUM = ONE + CALL DLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM ) + PL = RDSCAL*SQRT( DSUM ) + IF( PL.EQ.ZERO ) THEN + PL = ONE + ELSE + PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) ) + END IF + RDSCAL = ZERO + DSUM = ONE + CALL DLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM ) + PR = RDSCAL*SQRT( DSUM ) + IF( PR.EQ.ZERO ) THEN + PR = ONE + ELSE + PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) ) + END IF + END IF +* + IF( WANTD ) THEN +* +* Compute estimates of Difu and Difl. +* + IF( WANTD1 ) THEN + N1 = M + N2 = N - M + I = N1 + 1 + IJB = IDIFJB +* +* Frobenius norm-based Difu-estimate. +* + CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, + $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), + $ N1, DSCALE, DIF( 1 ), WORK( 2*N1*N2+1 ), + $ LWORK-2*N1*N2, IWORK, IERR ) +* +* Frobenius norm-based Difl-estimate. +* + CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK, + $ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ), + $ N2, DSCALE, DIF( 2 ), WORK( 2*N1*N2+1 ), + $ LWORK-2*N1*N2, IWORK, 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 = 2*N1*N2 +* +* 1-norm-based estimate of Difu. +* + 40 CONTINUE + CALL DLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 1 ), + $ KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN +* +* Solve generalized Sylvester equation. +* + CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, + $ WORK, N1, B, LDB, B( I, I ), LDB, + $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), + $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, + $ IERR ) + ELSE +* +* Solve the transposed variant. +* + CALL DTGSYL( 'T', IJB, N1, N2, A, LDA, A( I, I ), LDA, + $ WORK, N1, B, LDB, B( I, I ), LDB, + $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), + $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, + $ IERR ) + END IF + GO TO 40 + END IF + DIF( 1 ) = DSCALE / DIF( 1 ) +* +* 1-norm-based estimate of Difl. +* + 50 CONTINUE + CALL DLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 2 ), + $ KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN +* +* Solve generalized Sylvester equation. +* + CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, + $ WORK, N2, B( I, I ), LDB, B, LDB, + $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), + $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, + $ IERR ) + ELSE +* +* Solve the transposed variant. +* + CALL DTGSYL( 'T', IJB, N2, N1, A( I, I ), LDA, A, LDA, + $ WORK, N2, B( I, I ), LDB, B, LDB, + $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), + $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, + $ IERR ) + END IF + GO TO 50 + END IF + DIF( 2 ) = DSCALE / DIF( 2 ) +* + END IF + END IF +* + 60 CONTINUE +* +* Compute generalized eigenvalues of reordered pair (A, B) and +* normalize the generalized Schur form. +* + PAIR = .FALSE. + DO 80 K = 1, N + IF( PAIR ) THEN + PAIR = .FALSE. + ELSE +* + IF( K.LT.N ) THEN + IF( A( K+1, K ).NE.ZERO ) THEN + PAIR = .TRUE. + END IF + END IF +* + IF( PAIR ) THEN +* +* Compute the eigenvalue(s) at position K. +* + WORK( 1 ) = A( K, K ) + WORK( 2 ) = A( K+1, K ) + WORK( 3 ) = A( K, K+1 ) + WORK( 4 ) = A( K+1, K+1 ) + WORK( 5 ) = B( K, K ) + WORK( 6 ) = B( K+1, K ) + WORK( 7 ) = B( K, K+1 ) + WORK( 8 ) = B( K+1, K+1 ) + CALL DLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA( K ), + $ BETA( K+1 ), ALPHAR( K ), ALPHAR( K+1 ), + $ ALPHAI( K ) ) + ALPHAI( K+1 ) = -ALPHAI( K ) +* + ELSE +* + IF( SIGN( ONE, B( K, K ) ).LT.ZERO ) THEN +* +* If B(K,K) is negative, make it positive +* + DO 70 I = 1, N + A( K, I ) = -A( K, I ) + B( K, I ) = -B( K, I ) + Q( I, K ) = -Q( I, K ) + 70 CONTINUE + END IF +* + ALPHAR( K ) = A( K, K ) + ALPHAI( K ) = ZERO + BETA( K ) = B( K, K ) +* + END IF + END IF + 80 CONTINUE +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of DTGSEN +* + END diff --git a/2.3-1/src/fortran/lapack/dtgsy2.f b/2.3-1/src/fortran/lapack/dtgsy2.f new file mode 100644 index 00000000..3ebc912f --- /dev/null +++ b/2.3-1/src/fortran/lapack/dtgsy2.f @@ -0,0 +1,956 @@ + SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, + $ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, + $ IWORK, PQ, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N, + $ PQ + DOUBLE PRECISION RDSCAL, RDSUM, SCALE +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), E( LDE, * ), F( LDF, * ) +* .. +* +* 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 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 +* DTGSYL. 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. (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 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. +* +* 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 .. + INTEGER LDZ + PARAMETER ( LDZ = 8 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN + INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1, + $ K, MB, NB, P, Q, ZDIM + DOUBLE PRECISION ALPHA, SCALOC +* .. +* .. Local Arrays .. + INTEGER IPIV( LDZ ), JPIV( LDZ ) + DOUBLE PRECISION RHS( LDZ ), Z( LDZ, LDZ ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGER, DGESC2, + $ DGETC2, DLASET, DLATDF, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Decode and test input parameters +* + INFO = 0 + IERR = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -1 + ELSE IF( NOTRAN ) THEN + IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN + INFO = -2 + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( M.LE.0 ) THEN + INFO = -3 + ELSE IF( N.LE.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, M ) ) THEN + INFO = -12 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -16 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTGSY2', -INFO ) + RETURN + END IF +* +* Determine block structure of A +* + PQ = 0 + P = 0 + I = 1 + 10 CONTINUE + IF( I.GT.M ) + $ GO TO 20 + P = P + 1 + IWORK( P ) = I + IF( I.EQ.M ) + $ GO TO 20 + IF( A( I+1, I ).NE.ZERO ) THEN + I = I + 2 + ELSE + I = I + 1 + END IF + GO TO 10 + 20 CONTINUE + IWORK( P+1 ) = M + 1 +* +* Determine block structure of B +* + Q = P + 1 + J = 1 + 30 CONTINUE + IF( J.GT.N ) + $ GO TO 40 + Q = Q + 1 + IWORK( Q ) = J + IF( J.EQ.N ) + $ GO TO 40 + IF( B( J+1, J ).NE.ZERO ) THEN + J = J + 2 + ELSE + J = J + 1 + END IF + GO TO 30 + 40 CONTINUE + IWORK( Q+1 ) = N + 1 + PQ = P*( Q-P-1 ) +* + IF( NOTRAN ) THEN +* +* 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 = ONE + SCALOC = ONE + DO 120 J = P + 2, Q + JS = IWORK( J ) + JSP1 = JS + 1 + JE = IWORK( J+1 ) - 1 + NB = JE - JS + 1 + DO 110 I = P, 1, -1 +* + IS = IWORK( I ) + ISP1 = IS + 1 + IE = IWORK( I+1 ) - 1 + MB = IE - IS + 1 + ZDIM = MB*NB*2 +* + IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN +* +* Build a 2-by-2 system Z * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = D( IS, IS ) + Z( 1, 2 ) = -B( JS, JS ) + Z( 2, 2 ) = -E( JS, JS ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = F( IS, JS ) +* +* Solve Z * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR +* + IF( IJOB.EQ.0 ) THEN + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, + $ SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 50 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 50 CONTINUE + SCALE = SCALE*SCALOC + END IF + ELSE + CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, + $ RDSCAL, IPIV, JPIV ) + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + F( IS, JS ) = RHS( 2 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( I.GT.1 ) THEN + ALPHA = -RHS( 1 ) + CALL DAXPY( IS-1, ALPHA, A( 1, IS ), 1, C( 1, JS ), + $ 1 ) + CALL DAXPY( IS-1, ALPHA, D( 1, IS ), 1, F( 1, JS ), + $ 1 ) + END IF + IF( J.LT.Q ) THEN + CALL DAXPY( N-JE, RHS( 2 ), B( JS, JE+1 ), LDB, + $ C( IS, JE+1 ), LDC ) + CALL DAXPY( N-JE, RHS( 2 ), E( JS, JE+1 ), LDE, + $ F( IS, JE+1 ), LDF ) + END IF +* + ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN +* +* Build a 4-by-4 system Z * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = ZERO + Z( 3, 1 ) = D( IS, IS ) + Z( 4, 1 ) = ZERO +* + Z( 1, 2 ) = ZERO + Z( 2, 2 ) = A( IS, IS ) + Z( 3, 2 ) = ZERO + Z( 4, 2 ) = D( IS, IS ) +* + Z( 1, 3 ) = -B( JS, JS ) + Z( 2, 3 ) = -B( JS, JSP1 ) + Z( 3, 3 ) = -E( JS, JS ) + Z( 4, 3 ) = -E( JS, JSP1 ) +* + Z( 1, 4 ) = -B( JSP1, JS ) + Z( 2, 4 ) = -B( JSP1, JSP1 ) + Z( 3, 4 ) = ZERO + Z( 4, 4 ) = -E( JSP1, JSP1 ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = C( IS, JSP1 ) + RHS( 3 ) = F( IS, JS ) + RHS( 4 ) = F( IS, JSP1 ) +* +* Solve Z * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR +* + IF( IJOB.EQ.0 ) THEN + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, + $ SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 60 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 60 CONTINUE + SCALE = SCALE*SCALOC + END IF + ELSE + CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, + $ RDSCAL, IPIV, JPIV ) + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + C( IS, JSP1 ) = RHS( 2 ) + F( IS, JS ) = RHS( 3 ) + F( IS, JSP1 ) = RHS( 4 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( I.GT.1 ) THEN + CALL DGER( IS-1, NB, -ONE, A( 1, IS ), 1, RHS( 1 ), + $ 1, C( 1, JS ), LDC ) + CALL DGER( IS-1, NB, -ONE, D( 1, IS ), 1, RHS( 1 ), + $ 1, F( 1, JS ), LDF ) + END IF + IF( J.LT.Q ) THEN + CALL DAXPY( N-JE, RHS( 3 ), B( JS, JE+1 ), LDB, + $ C( IS, JE+1 ), LDC ) + CALL DAXPY( N-JE, RHS( 3 ), E( JS, JE+1 ), LDE, + $ F( IS, JE+1 ), LDF ) + CALL DAXPY( N-JE, RHS( 4 ), B( JSP1, JE+1 ), LDB, + $ C( IS, JE+1 ), LDC ) + CALL DAXPY( N-JE, RHS( 4 ), E( JSP1, JE+1 ), LDE, + $ F( IS, JE+1 ), LDF ) + END IF +* + ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN +* +* Build a 4-by-4 system Z * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = A( ISP1, IS ) + Z( 3, 1 ) = D( IS, IS ) + Z( 4, 1 ) = ZERO +* + Z( 1, 2 ) = A( IS, ISP1 ) + Z( 2, 2 ) = A( ISP1, ISP1 ) + Z( 3, 2 ) = D( IS, ISP1 ) + Z( 4, 2 ) = D( ISP1, ISP1 ) +* + Z( 1, 3 ) = -B( JS, JS ) + Z( 2, 3 ) = ZERO + Z( 3, 3 ) = -E( JS, JS ) + Z( 4, 3 ) = ZERO +* + Z( 1, 4 ) = ZERO + Z( 2, 4 ) = -B( JS, JS ) + Z( 3, 4 ) = ZERO + Z( 4, 4 ) = -E( JS, JS ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = C( ISP1, JS ) + RHS( 3 ) = F( IS, JS ) + RHS( 4 ) = F( ISP1, JS ) +* +* Solve Z * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR + IF( IJOB.EQ.0 ) THEN + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, + $ SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 70 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 70 CONTINUE + SCALE = SCALE*SCALOC + END IF + ELSE + CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, + $ RDSCAL, IPIV, JPIV ) + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + C( ISP1, JS ) = RHS( 2 ) + F( IS, JS ) = RHS( 3 ) + F( ISP1, JS ) = RHS( 4 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( I.GT.1 ) THEN + CALL DGEMV( 'N', IS-1, MB, -ONE, A( 1, IS ), LDA, + $ RHS( 1 ), 1, ONE, C( 1, JS ), 1 ) + CALL DGEMV( 'N', IS-1, MB, -ONE, D( 1, IS ), LDD, + $ RHS( 1 ), 1, ONE, F( 1, JS ), 1 ) + END IF + IF( J.LT.Q ) THEN + CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1, + $ B( JS, JE+1 ), LDB, C( IS, JE+1 ), LDC ) + CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1, + $ E( JS, JE+1 ), LDB, F( IS, JE+1 ), LDC ) + END IF +* + ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN +* +* Build an 8-by-8 system Z * x = RHS +* + CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = A( ISP1, IS ) + Z( 5, 1 ) = D( IS, IS ) +* + Z( 1, 2 ) = A( IS, ISP1 ) + Z( 2, 2 ) = A( ISP1, ISP1 ) + Z( 5, 2 ) = D( IS, ISP1 ) + Z( 6, 2 ) = D( ISP1, ISP1 ) +* + Z( 3, 3 ) = A( IS, IS ) + Z( 4, 3 ) = A( ISP1, IS ) + Z( 7, 3 ) = D( IS, IS ) +* + Z( 3, 4 ) = A( IS, ISP1 ) + Z( 4, 4 ) = A( ISP1, ISP1 ) + Z( 7, 4 ) = D( IS, ISP1 ) + Z( 8, 4 ) = D( ISP1, ISP1 ) +* + Z( 1, 5 ) = -B( JS, JS ) + Z( 3, 5 ) = -B( JS, JSP1 ) + Z( 5, 5 ) = -E( JS, JS ) + Z( 7, 5 ) = -E( JS, JSP1 ) +* + Z( 2, 6 ) = -B( JS, JS ) + Z( 4, 6 ) = -B( JS, JSP1 ) + Z( 6, 6 ) = -E( JS, JS ) + Z( 8, 6 ) = -E( JS, JSP1 ) +* + Z( 1, 7 ) = -B( JSP1, JS ) + Z( 3, 7 ) = -B( JSP1, JSP1 ) + Z( 7, 7 ) = -E( JSP1, JSP1 ) +* + Z( 2, 8 ) = -B( JSP1, JS ) + Z( 4, 8 ) = -B( JSP1, JSP1 ) + Z( 8, 8 ) = -E( JSP1, JSP1 ) +* +* Set up right hand side(s) +* + K = 1 + II = MB*NB + 1 + DO 80 JJ = 0, NB - 1 + CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 ) + CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 ) + K = K + MB + II = II + MB + 80 CONTINUE +* +* Solve Z * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR + IF( IJOB.EQ.0 ) THEN + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, + $ SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 90 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 90 CONTINUE + SCALE = SCALE*SCALOC + END IF + ELSE + CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, + $ RDSCAL, IPIV, JPIV ) + END IF +* +* Unpack solution vector(s) +* + K = 1 + II = MB*NB + 1 + DO 100 JJ = 0, NB - 1 + CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 ) + CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 ) + K = K + MB + II = II + MB + 100 CONTINUE +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( I.GT.1 ) THEN + CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, + $ A( 1, IS ), LDA, RHS( 1 ), MB, ONE, + $ C( 1, JS ), LDC ) + CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, + $ D( 1, IS ), LDD, RHS( 1 ), MB, ONE, + $ F( 1, JS ), LDF ) + END IF + IF( J.LT.Q ) THEN + K = MB*NB + 1 + CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ), + $ MB, B( JS, JE+1 ), LDB, ONE, + $ C( IS, JE+1 ), LDC ) + CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ), + $ MB, E( JS, JE+1 ), LDE, ONE, + $ F( IS, JE+1 ), LDF ) + END IF +* + END IF +* + 110 CONTINUE + 120 CONTINUE + 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 = ONE + SCALOC = ONE + DO 200 I = 1, P +* + IS = IWORK( I ) + ISP1 = IS + 1 + IE = ( I+1 ) - 1 + MB = IE - IS + 1 + DO 190 J = Q, P + 2, -1 +* + JS = IWORK( J ) + JSP1 = JS + 1 + JE = IWORK( J+1 ) - 1 + NB = JE - JS + 1 + ZDIM = MB*NB*2 + IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN +* +* Build a 2-by-2 system Z' * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = -B( JS, JS ) + Z( 1, 2 ) = D( IS, IS ) + Z( 2, 2 ) = -E( JS, JS ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = F( IS, JS ) +* +* Solve Z' * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR +* + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 130 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 130 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + F( IS, JS ) = RHS( 2 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( J.GT.P+2 ) THEN + ALPHA = RHS( 1 ) + CALL DAXPY( JS-1, ALPHA, B( 1, JS ), 1, F( IS, 1 ), + $ LDF ) + ALPHA = RHS( 2 ) + CALL DAXPY( JS-1, ALPHA, E( 1, JS ), 1, F( IS, 1 ), + $ LDF ) + END IF + IF( I.LT.P ) THEN + ALPHA = -RHS( 1 ) + CALL DAXPY( M-IE, ALPHA, A( IS, IE+1 ), LDA, + $ C( IE+1, JS ), 1 ) + ALPHA = -RHS( 2 ) + CALL DAXPY( M-IE, ALPHA, D( IS, IE+1 ), LDD, + $ C( IE+1, JS ), 1 ) + END IF +* + ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN +* +* Build a 4-by-4 system Z' * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = ZERO + Z( 3, 1 ) = -B( JS, JS ) + Z( 4, 1 ) = -B( JSP1, JS ) +* + Z( 1, 2 ) = ZERO + Z( 2, 2 ) = A( IS, IS ) + Z( 3, 2 ) = -B( JS, JSP1 ) + Z( 4, 2 ) = -B( JSP1, JSP1 ) +* + Z( 1, 3 ) = D( IS, IS ) + Z( 2, 3 ) = ZERO + Z( 3, 3 ) = -E( JS, JS ) + Z( 4, 3 ) = ZERO +* + Z( 1, 4 ) = ZERO + Z( 2, 4 ) = D( IS, IS ) + Z( 3, 4 ) = -E( JS, JSP1 ) + Z( 4, 4 ) = -E( JSP1, JSP1 ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = C( IS, JSP1 ) + RHS( 3 ) = F( IS, JS ) + RHS( 4 ) = F( IS, JSP1 ) +* +* Solve Z' * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 140 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 140 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + C( IS, JSP1 ) = RHS( 2 ) + F( IS, JS ) = RHS( 3 ) + F( IS, JSP1 ) = RHS( 4 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( J.GT.P+2 ) THEN + CALL DAXPY( JS-1, RHS( 1 ), B( 1, JS ), 1, + $ F( IS, 1 ), LDF ) + CALL DAXPY( JS-1, RHS( 2 ), B( 1, JSP1 ), 1, + $ F( IS, 1 ), LDF ) + CALL DAXPY( JS-1, RHS( 3 ), E( 1, JS ), 1, + $ F( IS, 1 ), LDF ) + CALL DAXPY( JS-1, RHS( 4 ), E( 1, JSP1 ), 1, + $ F( IS, 1 ), LDF ) + END IF + IF( I.LT.P ) THEN + CALL DGER( M-IE, NB, -ONE, A( IS, IE+1 ), LDA, + $ RHS( 1 ), 1, C( IE+1, JS ), LDC ) + CALL DGER( M-IE, NB, -ONE, D( IS, IE+1 ), LDD, + $ RHS( 3 ), 1, C( IE+1, JS ), LDC ) + END IF +* + ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN +* +* Build a 4-by-4 system Z' * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = A( IS, ISP1 ) + Z( 3, 1 ) = -B( JS, JS ) + Z( 4, 1 ) = ZERO +* + Z( 1, 2 ) = A( ISP1, IS ) + Z( 2, 2 ) = A( ISP1, ISP1 ) + Z( 3, 2 ) = ZERO + Z( 4, 2 ) = -B( JS, JS ) +* + Z( 1, 3 ) = D( IS, IS ) + Z( 2, 3 ) = D( IS, ISP1 ) + Z( 3, 3 ) = -E( JS, JS ) + Z( 4, 3 ) = ZERO +* + Z( 1, 4 ) = ZERO + Z( 2, 4 ) = D( ISP1, ISP1 ) + Z( 3, 4 ) = ZERO + Z( 4, 4 ) = -E( JS, JS ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = C( ISP1, JS ) + RHS( 3 ) = F( IS, JS ) + RHS( 4 ) = F( ISP1, JS ) +* +* Solve Z' * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR +* + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 150 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 150 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + C( ISP1, JS ) = RHS( 2 ) + F( IS, JS ) = RHS( 3 ) + F( ISP1, JS ) = RHS( 4 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( J.GT.P+2 ) THEN + CALL DGER( MB, JS-1, ONE, RHS( 1 ), 1, B( 1, JS ), + $ 1, F( IS, 1 ), LDF ) + CALL DGER( MB, JS-1, ONE, RHS( 3 ), 1, E( 1, JS ), + $ 1, F( IS, 1 ), LDF ) + END IF + IF( I.LT.P ) THEN + CALL DGEMV( 'T', MB, M-IE, -ONE, A( IS, IE+1 ), + $ LDA, RHS( 1 ), 1, ONE, C( IE+1, JS ), + $ 1 ) + CALL DGEMV( 'T', MB, M-IE, -ONE, D( IS, IE+1 ), + $ LDD, RHS( 3 ), 1, ONE, C( IE+1, JS ), + $ 1 ) + END IF +* + ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN +* +* Build an 8-by-8 system Z' * x = RHS +* + CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = A( IS, ISP1 ) + Z( 5, 1 ) = -B( JS, JS ) + Z( 7, 1 ) = -B( JSP1, JS ) +* + Z( 1, 2 ) = A( ISP1, IS ) + Z( 2, 2 ) = A( ISP1, ISP1 ) + Z( 6, 2 ) = -B( JS, JS ) + Z( 8, 2 ) = -B( JSP1, JS ) +* + Z( 3, 3 ) = A( IS, IS ) + Z( 4, 3 ) = A( IS, ISP1 ) + Z( 5, 3 ) = -B( JS, JSP1 ) + Z( 7, 3 ) = -B( JSP1, JSP1 ) +* + Z( 3, 4 ) = A( ISP1, IS ) + Z( 4, 4 ) = A( ISP1, ISP1 ) + Z( 6, 4 ) = -B( JS, JSP1 ) + Z( 8, 4 ) = -B( JSP1, JSP1 ) +* + Z( 1, 5 ) = D( IS, IS ) + Z( 2, 5 ) = D( IS, ISP1 ) + Z( 5, 5 ) = -E( JS, JS ) +* + Z( 2, 6 ) = D( ISP1, ISP1 ) + Z( 6, 6 ) = -E( JS, JS ) +* + Z( 3, 7 ) = D( IS, IS ) + Z( 4, 7 ) = D( IS, ISP1 ) + Z( 5, 7 ) = -E( JS, JSP1 ) + Z( 7, 7 ) = -E( JSP1, JSP1 ) +* + Z( 4, 8 ) = D( ISP1, ISP1 ) + Z( 6, 8 ) = -E( JS, JSP1 ) + Z( 8, 8 ) = -E( JSP1, JSP1 ) +* +* Set up right hand side(s) +* + K = 1 + II = MB*NB + 1 + DO 160 JJ = 0, NB - 1 + CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 ) + CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 ) + K = K + MB + II = II + MB + 160 CONTINUE +* +* +* Solve Z' * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR +* + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 170 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 170 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Unpack solution vector(s) +* + K = 1 + II = MB*NB + 1 + DO 180 JJ = 0, NB - 1 + CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 ) + CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 ) + K = K + MB + II = II + MB + 180 CONTINUE +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( J.GT.P+2 ) THEN + CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, + $ C( IS, JS ), LDC, B( 1, JS ), LDB, ONE, + $ F( IS, 1 ), LDF ) + CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, + $ F( IS, JS ), LDF, E( 1, JS ), LDE, ONE, + $ F( IS, 1 ), LDF ) + END IF + IF( I.LT.P ) THEN + CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, + $ A( IS, IE+1 ), LDA, C( IS, JS ), LDC, + $ ONE, C( IE+1, JS ), LDC ) + CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, + $ D( IS, IE+1 ), LDD, F( IS, JS ), LDF, + $ ONE, C( IE+1, JS ), LDC ) + END IF +* + END IF +* + 190 CONTINUE + 200 CONTINUE +* + END IF + RETURN +* +* End of DTGSY2 +* + END diff --git a/2.3-1/src/fortran/lapack/dtgsyl.f b/2.3-1/src/fortran/lapack/dtgsyl.f new file mode 100644 index 00000000..01866717 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dtgsyl.f @@ -0,0 +1,556 @@ + SUBROUTINE DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, + $ LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, + $ IWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, + $ LWORK, M, N + DOUBLE PRECISION DIF, SCALE +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), E( LDE, * ), F( LDF, * ), + $ WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, NOTRAN + INTEGER I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K, + $ LINFO, LWMIN, MB, NB, P, PPQQ, PQ, Q + DOUBLE PRECISION DSCALE, DSUM, SCALE2, SCALOC +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASET, DSCAL, DTGSY2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode and test input parameters +* + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -1 + ELSE IF( NOTRAN ) THEN + IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.4 ) ) THEN + INFO = -2 + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( M.LE.0 ) THEN + INFO = -3 + ELSE IF( N.LE.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, M ) ) THEN + INFO = -12 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -16 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + IF( NOTRAN ) THEN + IF( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN + LWMIN = MAX( 1, 2*M*N ) + ELSE + LWMIN = 1 + END IF + ELSE + LWMIN = 1 + END IF + WORK( 1 ) = LWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -20 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTGSYL', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + SCALE = 1 + IF( NOTRAN ) THEN + IF( IJOB.NE.0 ) THEN + DIF = 0 + END IF + END IF + RETURN + END IF +* +* Determine optimal block sizes MB and NB +* + MB = ILAENV( 2, 'DTGSYL', TRANS, M, N, -1, -1 ) + NB = ILAENV( 5, 'DTGSYL', TRANS, M, N, -1, -1 ) +* + ISOLVE = 1 + IFUNC = 0 + IF( NOTRAN ) THEN + IF( IJOB.GE.3 ) THEN + IFUNC = IJOB - 2 + CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC ) + CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF ) + ELSE IF( IJOB.GE.1 ) THEN + ISOLVE = 2 + END IF + END IF +* + IF( ( MB.LE.1 .AND. NB.LE.1 ) .OR. ( MB.GE.M .AND. NB.GE.N ) ) + $ THEN +* + DO 30 IROUND = 1, ISOLVE +* +* Use unblocked Level 2 solver +* + DSCALE = ZERO + DSUM = ONE + PQ = 0 + CALL DTGSY2( TRANS, IFUNC, M, N, A, LDA, B, LDB, C, LDC, D, + $ LDD, E, LDE, F, LDF, SCALE, DSUM, DSCALE, + $ IWORK, PQ, INFO ) + IF( DSCALE.NE.ZERO ) THEN + IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN + DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) ) + ELSE + DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) ) + END IF + END IF +* + IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN + IF( NOTRAN ) THEN + IFUNC = IJOB + END IF + SCALE2 = SCALE + CALL DLACPY( 'F', M, N, C, LDC, WORK, M ) + CALL DLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M ) + CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC ) + CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF ) + ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN + CALL DLACPY( 'F', M, N, WORK, M, C, LDC ) + CALL DLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF ) + SCALE = SCALE2 + END IF + 30 CONTINUE +* + RETURN + END IF +* +* Determine block structure of A +* + P = 0 + I = 1 + 40 CONTINUE + IF( I.GT.M ) + $ GO TO 50 + P = P + 1 + IWORK( P ) = I + I = I + MB + IF( I.GE.M ) + $ GO TO 50 + IF( A( I, I-1 ).NE.ZERO ) + $ I = I + 1 + GO TO 40 + 50 CONTINUE +* + IWORK( P+1 ) = M + 1 + IF( IWORK( P ).EQ.IWORK( P+1 ) ) + $ P = P - 1 +* +* Determine block structure of B +* + Q = P + 1 + J = 1 + 60 CONTINUE + IF( J.GT.N ) + $ GO TO 70 + Q = Q + 1 + IWORK( Q ) = J + J = J + NB + IF( J.GE.N ) + $ GO TO 70 + IF( B( J, J-1 ).NE.ZERO ) + $ J = J + 1 + GO TO 60 + 70 CONTINUE +* + IWORK( Q+1 ) = N + 1 + IF( IWORK( Q ).EQ.IWORK( Q+1 ) ) + $ Q = Q - 1 +* + IF( NOTRAN ) THEN +* + DO 150 IROUND = 1, ISOLVE +* +* 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 = ZERO + DSUM = ONE + PQ = 0 + SCALE = ONE + DO 130 J = P + 2, Q + JS = IWORK( J ) + JE = IWORK( J+1 ) - 1 + NB = JE - JS + 1 + DO 120 I = P, 1, -1 + IS = IWORK( I ) + IE = IWORK( I+1 ) - 1 + MB = IE - IS + 1 + PPQQ = 0 + CALL DTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA, + $ B( JS, JS ), LDB, C( IS, JS ), LDC, + $ D( IS, IS ), LDD, E( JS, JS ), LDE, + $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE, + $ IWORK( Q+2 ), PPQQ, LINFO ) + IF( LINFO.GT.0 ) + $ INFO = LINFO +* + PQ = PQ + PPQQ + IF( SCALOC.NE.ONE ) THEN + DO 80 K = 1, JS - 1 + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 80 CONTINUE + DO 90 K = JS, JE + CALL DSCAL( IS-1, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( IS-1, SCALOC, F( 1, K ), 1 ) + 90 CONTINUE + DO 100 K = JS, JE + CALL DSCAL( M-IE, SCALOC, C( IE+1, K ), 1 ) + CALL DSCAL( M-IE, SCALOC, F( IE+1, K ), 1 ) + 100 CONTINUE + DO 110 K = JE + 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 110 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( I.GT.1 ) THEN + CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, + $ A( 1, IS ), LDA, C( IS, JS ), LDC, ONE, + $ C( 1, JS ), LDC ) + CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, + $ D( 1, IS ), LDD, C( IS, JS ), LDC, ONE, + $ F( 1, JS ), LDF ) + END IF + IF( J.LT.Q ) THEN + CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, + $ F( IS, JS ), LDF, B( JS, JE+1 ), LDB, + $ ONE, C( IS, JE+1 ), LDC ) + CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, + $ F( IS, JS ), LDF, E( JS, JE+1 ), LDE, + $ ONE, F( IS, JE+1 ), LDF ) + END IF + 120 CONTINUE + 130 CONTINUE + IF( DSCALE.NE.ZERO ) THEN + IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN + DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) ) + ELSE + DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) ) + END IF + END IF + IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN + IF( NOTRAN ) THEN + IFUNC = IJOB + END IF + SCALE2 = SCALE + CALL DLACPY( 'F', M, N, C, LDC, WORK, M ) + CALL DLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M ) + CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC ) + CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF ) + ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN + CALL DLACPY( 'F', M, N, WORK, M, C, LDC ) + CALL DLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF ) + SCALE = SCALE2 + END IF + 150 CONTINUE +* + 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 = ONE + DO 210 I = 1, P + IS = IWORK( I ) + IE = IWORK( I+1 ) - 1 + MB = IE - IS + 1 + DO 200 J = Q, P + 2, -1 + JS = IWORK( J ) + JE = IWORK( J+1 ) - 1 + NB = JE - JS + 1 + CALL DTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA, + $ B( JS, JS ), LDB, C( IS, JS ), LDC, + $ D( IS, IS ), LDD, E( JS, JS ), LDE, + $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE, + $ IWORK( Q+2 ), PPQQ, LINFO ) + IF( LINFO.GT.0 ) + $ INFO = LINFO + IF( SCALOC.NE.ONE ) THEN + DO 160 K = 1, JS - 1 + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 160 CONTINUE + DO 170 K = JS, JE + CALL DSCAL( IS-1, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( IS-1, SCALOC, F( 1, K ), 1 ) + 170 CONTINUE + DO 180 K = JS, JE + CALL DSCAL( M-IE, SCALOC, C( IE+1, K ), 1 ) + CALL DSCAL( M-IE, SCALOC, F( IE+1, K ), 1 ) + 180 CONTINUE + DO 190 K = JE + 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 190 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Substitute R(I, J) and L(I, J) into remaining equation. +* + IF( J.GT.P+2 ) THEN + CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, C( IS, JS ), + $ LDC, B( 1, JS ), LDB, ONE, F( IS, 1 ), + $ LDF ) + CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, F( IS, JS ), + $ LDF, E( 1, JS ), LDE, ONE, F( IS, 1 ), + $ LDF ) + END IF + IF( I.LT.P ) THEN + CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, + $ A( IS, IE+1 ), LDA, C( IS, JS ), LDC, ONE, + $ C( IE+1, JS ), LDC ) + CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, + $ D( IS, IE+1 ), LDD, F( IS, JS ), LDF, ONE, + $ C( IE+1, JS ), LDC ) + END IF + 200 CONTINUE + 210 CONTINUE +* + END IF +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of DTGSYL +* + END diff --git a/2.3-1/src/fortran/lapack/dtrcon.f b/2.3-1/src/fortran/lapack/dtrcon.f new file mode 100644 index 00000000..23da5927 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dtrcon.f @@ -0,0 +1,197 @@ + SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, + $ IWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* 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 .. + CHARACTER DIAG, NORM, UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT, ONENRM, UPPER + CHARACTER NORMIN + INTEGER IX, KASE, KASE1 + DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLANTR + EXTERNAL LSAME, IDAMAX, DLAMCH, DLANTR +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) + NOUNIT = LSAME( DIAG, 'N' ) +* + IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTRCON', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + END IF +* + RCOND = ZERO + SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) ) +* +* Compute the norm of the triangular matrix A. +* + ANORM = DLANTR( NORM, UPLO, DIAG, N, N, A, LDA, WORK ) +* +* Continue only if ANORM > 0. +* + IF( ANORM.GT.ZERO ) THEN +* +* Estimate the norm of the inverse of A. +* + AINVNM = ZERO + NORMIN = 'N' + IF( ONENRM ) THEN + KASE1 = 1 + ELSE + KASE1 = 2 + END IF + KASE = 0 + 10 CONTINUE + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.KASE1 ) THEN +* +* Multiply by inv(A). +* + CALL DLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A, + $ LDA, WORK, SCALE, WORK( 2*N+1 ), INFO ) + ELSE +* +* Multiply by inv(A'). +* + CALL DLATRS( UPLO, 'Transpose', DIAG, NORMIN, N, A, LDA, + $ WORK, SCALE, WORK( 2*N+1 ), INFO ) + END IF + NORMIN = 'Y' +* +* Multiply by 1/SCALE if doing so will not cause overflow. +* + IF( SCALE.NE.ONE ) THEN + IX = IDAMAX( N, WORK, 1 ) + XNORM = ABS( WORK( IX ) ) + IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO ) + $ GO TO 20 + CALL DRSCL( N, SCALE, WORK, 1 ) + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / ANORM ) / AINVNM + END IF +* + 20 CONTINUE + RETURN +* +* End of DTRCON +* + END diff --git a/2.3-1/src/fortran/lapack/dtrevc.f b/2.3-1/src/fortran/lapack/dtrevc.f new file mode 100644 index 00000000..a0215f02 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dtrevc.f @@ -0,0 +1,980 @@ + SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + $ LDVR, MM, M, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER HOWMNY, SIDE + INTEGER INFO, LDT, LDVL, LDVR, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV + INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2 + DOUBLE PRECISION BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE, + $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR, + $ XNORM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DLALN2, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Local Arrays .. + DOUBLE PRECISION X( 2, 2 ) +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + BOTHV = LSAME( SIDE, 'B' ) + RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV + LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV +* + ALLV = LSAME( HOWMNY, 'A' ) + OVER = LSAME( HOWMNY, 'B' ) + SOMEV = LSAME( HOWMNY, 'S' ) +* + INFO = 0 + IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -1 + ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN + 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 ) THEN + M = 0 + PAIR = .FALSE. + DO 10 J = 1, N + IF( PAIR ) THEN + PAIR = .FALSE. + SELECT( J ) = .FALSE. + ELSE + IF( J.LT.N ) THEN + IF( T( J+1, J ).EQ.ZERO ) THEN + IF( SELECT( J ) ) + $ M = M + 1 + ELSE + PAIR = .TRUE. + IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN + SELECT( J ) = .TRUE. + M = M + 2 + END IF + END IF + ELSE + IF( SELECT( N ) ) + $ M = M + 1 + END IF + END IF + 10 CONTINUE + ELSE + M = N + END IF +* + IF( MM.LT.M ) THEN + INFO = -11 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTREVC', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* +* Set the constants to control overflow. +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( N / ULP ) + BIGNUM = ( ONE-ULP ) / SMLNUM +* +* Compute 1-norm of each column of strictly upper triangular +* part of T to control overflow in triangular solver. +* + WORK( 1 ) = ZERO + DO 30 J = 2, N + WORK( J ) = ZERO + DO 20 I = 1, J - 1 + WORK( J ) = WORK( J ) + ABS( T( I, J ) ) + 20 CONTINUE + 30 CONTINUE +* +* 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 = 2*N +* + IF( RIGHTV ) THEN +* +* Compute right eigenvectors. +* + IP = 0 + IS = M + DO 140 KI = N, 1, -1 +* + IF( IP.EQ.1 ) + $ GO TO 130 + IF( KI.EQ.1 ) + $ GO TO 40 + IF( T( KI, KI-1 ).EQ.ZERO ) + $ GO TO 40 + IP = -1 +* + 40 CONTINUE + IF( SOMEV ) THEN + IF( IP.EQ.0 ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 130 + ELSE + IF( .NOT.SELECT( KI-1 ) ) + $ GO TO 130 + END IF + END IF +* +* Compute the KI-th eigenvalue (WR,WI). +* + WR = T( KI, KI ) + WI = ZERO + IF( IP.NE.0 ) + $ WI = SQRT( ABS( T( KI, KI-1 ) ) )* + $ SQRT( ABS( T( KI-1, KI ) ) ) + SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) +* + IF( IP.EQ.0 ) THEN +* +* Real right eigenvector +* + WORK( KI+N ) = ONE +* +* Form right-hand side +* + DO 50 K = 1, KI - 1 + WORK( K+N ) = -T( K, KI ) + 50 CONTINUE +* +* Solve the upper quasi-triangular system: +* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. +* + JNXT = KI - 1 + DO 60 J = KI - 1, 1, -1 + IF( J.GT.JNXT ) + $ GO TO 60 + J1 = J + J2 = J + JNXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + J1 = J - 1 + JNXT = J - 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* + CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale X(1,1) to avoid overflow when updating +* the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + IF( WORK( J ).GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + SCALE = SCALE / XNORM + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) + WORK( J+N ) = X( 1, 1 ) +* +* Update right-hand side +* + CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, + $ WORK( 1+N ), 1 ) +* + ELSE +* +* 2-by-2 diagonal block +* + CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, + $ T( J-1, J-1 ), LDT, ONE, ONE, + $ WORK( J-1+N ), N, WR, ZERO, X, 2, + $ SCALE, XNORM, IERR ) +* +* Scale X(1,1) and X(2,1) to avoid overflow when +* updating the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + BETA = MAX( WORK( J-1 ), WORK( J ) ) + IF( BETA.GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + X( 2, 1 ) = X( 2, 1 ) / XNORM + SCALE = SCALE / XNORM + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) + WORK( J-1+N ) = X( 1, 1 ) + WORK( J+N ) = X( 2, 1 ) +* +* Update right-hand side +* + CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, + $ WORK( 1+N ), 1 ) + CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, + $ WORK( 1+N ), 1 ) + END IF + 60 CONTINUE +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN + CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 ) +* + II = IDAMAX( KI, VR( 1, IS ), 1 ) + REMAX = ONE / ABS( VR( II, IS ) ) + CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) +* + DO 70 K = KI + 1, N + VR( K, IS ) = ZERO + 70 CONTINUE + ELSE + IF( KI.GT.1 ) + $ CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR, + $ WORK( 1+N ), 1, WORK( KI+N ), + $ VR( 1, KI ), 1 ) +* + II = IDAMAX( N, VR( 1, KI ), 1 ) + REMAX = ONE / ABS( VR( II, KI ) ) + CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) + END IF +* + 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( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN + WORK( KI-1+N ) = ONE + WORK( KI+N2 ) = WI / T( KI-1, KI ) + ELSE + WORK( KI-1+N ) = -WI / T( KI, KI-1 ) + WORK( KI+N2 ) = ONE + END IF + WORK( KI+N ) = ZERO + WORK( KI-1+N2 ) = ZERO +* +* Form right-hand side +* + DO 80 K = 1, KI - 2 + WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 ) + WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI ) + 80 CONTINUE +* +* Solve upper quasi-triangular system: +* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) +* + JNXT = KI - 2 + DO 90 J = KI - 2, 1, -1 + IF( J.GT.JNXT ) + $ GO TO 90 + J1 = J + J2 = J + JNXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + J1 = J - 1 + JNXT = J - 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* + CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, WI, + $ X, 2, SCALE, XNORM, IERR ) +* +* Scale X(1,1) and X(1,2) to avoid overflow when +* updating the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + IF( WORK( J ).GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + X( 1, 2 ) = X( 1, 2 ) / XNORM + SCALE = SCALE / XNORM + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) + CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) + END IF + WORK( J+N ) = X( 1, 1 ) + WORK( J+N2 ) = X( 1, 2 ) +* +* Update the right-hand side +* + CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, + $ WORK( 1+N ), 1 ) + CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1, + $ WORK( 1+N2 ), 1 ) +* + ELSE +* +* 2-by-2 diagonal block +* + CALL DLALN2( .FALSE., 2, 2, SMIN, ONE, + $ T( J-1, J-1 ), LDT, ONE, ONE, + $ WORK( J-1+N ), N, WR, WI, X, 2, SCALE, + $ XNORM, IERR ) +* +* Scale X to avoid overflow when updating +* the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + BETA = MAX( WORK( J-1 ), WORK( J ) ) + IF( BETA.GT.BIGNUM / XNORM ) THEN + REC = ONE / XNORM + X( 1, 1 ) = X( 1, 1 )*REC + X( 1, 2 ) = X( 1, 2 )*REC + X( 2, 1 ) = X( 2, 1 )*REC + X( 2, 2 ) = X( 2, 2 )*REC + SCALE = SCALE*REC + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) + CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) + END IF + WORK( J-1+N ) = X( 1, 1 ) + WORK( J+N ) = X( 2, 1 ) + WORK( J-1+N2 ) = X( 1, 2 ) + WORK( J+N2 ) = X( 2, 2 ) +* +* Update the right-hand side +* + CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, + $ WORK( 1+N ), 1 ) + CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, + $ WORK( 1+N ), 1 ) + CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1, + $ WORK( 1+N2 ), 1 ) + CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, + $ WORK( 1+N2 ), 1 ) + END IF + 90 CONTINUE +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN + CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 ) + CALL DCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 ) +* + EMAX = ZERO + DO 100 K = 1, KI + EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+ + $ ABS( VR( K, IS ) ) ) + 100 CONTINUE +* + REMAX = ONE / EMAX + CALL DSCAL( KI, REMAX, VR( 1, IS-1 ), 1 ) + CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) +* + DO 110 K = KI + 1, N + VR( K, IS-1 ) = ZERO + VR( K, IS ) = ZERO + 110 CONTINUE +* + ELSE +* + IF( KI.GT.2 ) THEN + CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, + $ WORK( 1+N ), 1, WORK( KI-1+N ), + $ VR( 1, KI-1 ), 1 ) + CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, + $ WORK( 1+N2 ), 1, WORK( KI+N2 ), + $ VR( 1, KI ), 1 ) + ELSE + CALL DSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 ) + CALL DSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 ) + END IF +* + EMAX = ZERO + DO 120 K = 1, N + EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+ + $ ABS( VR( K, KI ) ) ) + 120 CONTINUE + REMAX = ONE / EMAX + CALL DSCAL( N, REMAX, VR( 1, KI-1 ), 1 ) + CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) + END IF + END IF +* + IS = IS - 1 + IF( IP.NE.0 ) + $ IS = IS - 1 + 130 CONTINUE + IF( IP.EQ.1 ) + $ IP = 0 + IF( IP.EQ.-1 ) + $ IP = 1 + 140 CONTINUE + END IF +* + IF( LEFTV ) THEN +* +* Compute left eigenvectors. +* + IP = 0 + IS = 1 + DO 260 KI = 1, N +* + IF( IP.EQ.-1 ) + $ GO TO 250 + IF( KI.EQ.N ) + $ GO TO 150 + IF( T( KI+1, KI ).EQ.ZERO ) + $ GO TO 150 + IP = 1 +* + 150 CONTINUE + IF( SOMEV ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 250 + END IF +* +* Compute the KI-th eigenvalue (WR,WI). +* + WR = T( KI, KI ) + WI = ZERO + IF( IP.NE.0 ) + $ WI = SQRT( ABS( T( KI, KI+1 ) ) )* + $ SQRT( ABS( T( KI+1, KI ) ) ) + SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) +* + IF( IP.EQ.0 ) THEN +* +* Real left eigenvector. +* + WORK( KI+N ) = ONE +* +* Form right-hand side +* + DO 160 K = KI + 1, N + WORK( K+N ) = -T( KI, K ) + 160 CONTINUE +* +* Solve the quasi-triangular system: +* (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK +* + VMAX = ONE + VCRIT = BIGNUM +* + JNXT = KI + 1 + DO 170 J = KI + 1, N + IF( J.LT.JNXT ) + $ GO TO 170 + J1 = J + J2 = J + JNXT = J + 1 + IF( J.LT.N ) THEN + IF( T( J+1, J ).NE.ZERO ) THEN + J2 = J + 1 + JNXT = J + 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* +* Scale if necessary to avoid overflow when forming +* the right-hand side. +* + IF( WORK( J ).GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+N ) = WORK( J+N ) - + $ DDOT( J-KI-1, T( KI+1, J ), 1, + $ WORK( KI+1+N ), 1 ) +* +* Solve (T(J,J)-WR)'*X = WORK +* + CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) + WORK( J+N ) = X( 1, 1 ) + VMAX = MAX( ABS( WORK( J+N ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + ELSE +* +* 2-by-2 diagonal block +* +* Scale if necessary to avoid overflow when forming +* the right-hand side. +* + BETA = MAX( WORK( J ), WORK( J+1 ) ) + IF( BETA.GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+N ) = WORK( J+N ) - + $ DDOT( J-KI-1, T( KI+1, J ), 1, + $ WORK( KI+1+N ), 1 ) +* + WORK( J+1+N ) = WORK( J+1+N ) - + $ DDOT( J-KI-1, T( KI+1, J+1 ), 1, + $ WORK( KI+1+N ), 1 ) +* +* Solve +* [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 ) +* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) +* + CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) + WORK( J+N ) = X( 1, 1 ) + WORK( J+1+N ) = X( 2, 1 ) +* + VMAX = MAX( ABS( WORK( J+N ) ), + $ ABS( WORK( J+1+N ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + END IF + 170 CONTINUE +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.OVER ) THEN + CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) +* + II = IDAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 + REMAX = ONE / ABS( VL( II, IS ) ) + CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) +* + DO 180 K = 1, KI - 1 + VL( K, IS ) = ZERO + 180 CONTINUE +* + ELSE +* + IF( KI.LT.N ) + $ CALL DGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL, + $ WORK( KI+1+N ), 1, WORK( KI+N ), + $ VL( 1, KI ), 1 ) +* + II = IDAMAX( N, VL( 1, KI ), 1 ) + REMAX = ONE / ABS( VL( II, KI ) ) + CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) +* + END IF +* + 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( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN + WORK( KI+N ) = WI / T( KI, KI+1 ) + WORK( KI+1+N2 ) = ONE + ELSE + WORK( KI+N ) = ONE + WORK( KI+1+N2 ) = -WI / T( KI+1, KI ) + END IF + WORK( KI+1+N ) = ZERO + WORK( KI+N2 ) = ZERO +* +* Form right-hand side +* + DO 190 K = KI + 2, N + WORK( K+N ) = -WORK( KI+N )*T( KI, K ) + WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K ) + 190 CONTINUE +* +* Solve complex quasi-triangular system: +* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 +* + VMAX = ONE + VCRIT = BIGNUM +* + JNXT = KI + 2 + DO 200 J = KI + 2, N + IF( J.LT.JNXT ) + $ GO TO 200 + J1 = J + J2 = J + JNXT = J + 1 + IF( J.LT.N ) THEN + IF( T( J+1, J ).NE.ZERO ) THEN + J2 = J + 1 + JNXT = J + 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* +* Scale if necessary to avoid overflow when +* forming the right-hand side elements. +* + IF( WORK( J ).GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) + CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+N ) = WORK( J+N ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+N ), 1 ) + WORK( J+N2 ) = WORK( J+N2 ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+N2 ), 1 ) +* +* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 +* + CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, + $ -WI, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) + CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) + END IF + WORK( J+N ) = X( 1, 1 ) + WORK( J+N2 ) = X( 1, 2 ) + VMAX = MAX( ABS( WORK( J+N ) ), + $ ABS( WORK( J+N2 ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + ELSE +* +* 2-by-2 diagonal block +* +* Scale if necessary to avoid overflow when forming +* the right-hand side elements. +* + BETA = MAX( WORK( J ), WORK( J+1 ) ) + IF( BETA.GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) + CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+N ) = WORK( J+N ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+N ), 1 ) +* + WORK( J+N2 ) = WORK( J+N2 ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+N2 ), 1 ) +* + WORK( J+1+N ) = WORK( J+1+N ) - + $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, + $ WORK( KI+2+N ), 1 ) +* + WORK( J+1+N2 ) = WORK( J+1+N2 ) - + $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, + $ WORK( KI+2+N2 ), 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)] ) +* + CALL DLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, + $ -WI, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) + CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) + END IF + WORK( J+N ) = X( 1, 1 ) + WORK( J+N2 ) = X( 1, 2 ) + WORK( J+1+N ) = X( 2, 1 ) + WORK( J+1+N2 ) = X( 2, 2 ) + VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ), + $ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + END IF + 200 CONTINUE +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.OVER ) THEN + CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) + CALL DCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ), + $ 1 ) +* + EMAX = ZERO + DO 220 K = KI, N + EMAX = MAX( EMAX, ABS( VL( K, IS ) )+ + $ ABS( VL( K, IS+1 ) ) ) + 220 CONTINUE + REMAX = ONE / EMAX + CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) + CALL DSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 ) +* + DO 230 K = 1, KI - 1 + VL( K, IS ) = ZERO + VL( K, IS+1 ) = ZERO + 230 CONTINUE + ELSE + IF( KI.LT.N-1 ) THEN + CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), + $ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ), + $ VL( 1, KI ), 1 ) + CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), + $ LDVL, WORK( KI+2+N2 ), 1, + $ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) + ELSE + CALL DSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 ) + CALL DSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) + END IF +* + EMAX = ZERO + DO 240 K = 1, N + EMAX = MAX( EMAX, ABS( VL( K, KI ) )+ + $ ABS( VL( K, KI+1 ) ) ) + 240 CONTINUE + REMAX = ONE / EMAX + CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) + CALL DSCAL( N, REMAX, VL( 1, KI+1 ), 1 ) +* + END IF +* + END IF +* + IS = IS + 1 + IF( IP.NE.0 ) + $ IS = IS + 1 + 250 CONTINUE + IF( IP.EQ.-1 ) + $ IP = 0 + IF( IP.EQ.1 ) + $ IP = -1 +* + 260 CONTINUE +* + END IF +* + RETURN +* +* End of DTREVC +* + END diff --git a/2.3-1/src/fortran/lapack/dtrexc.f b/2.3-1/src/fortran/lapack/dtrexc.f new file mode 100644 index 00000000..db9be753 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dtrexc.f @@ -0,0 +1,345 @@ + SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, + $ INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER COMPQ + INTEGER IFST, ILST, INFO, LDQ, LDT, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL WANTQ + INTEGER HERE, NBF, NBL, NBNEXT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLAEXC, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Decode and test the input arguments. +* + INFO = 0 + WANTQ = LSAME( COMPQ, 'V' ) + IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN + INFO = -6 + ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN + INFO = -7 + ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTREXC', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* +* Determine the first row of specified block +* and find out it is 1 by 1 or 2 by 2. +* + IF( IFST.GT.1 ) THEN + IF( T( IFST, IFST-1 ).NE.ZERO ) + $ IFST = IFST - 1 + END IF + NBF = 1 + IF( IFST.LT.N ) THEN + IF( T( IFST+1, IFST ).NE.ZERO ) + $ NBF = 2 + END IF +* +* Determine the first row of the final block +* and find out it is 1 by 1 or 2 by 2. +* + IF( ILST.GT.1 ) THEN + IF( T( ILST, ILST-1 ).NE.ZERO ) + $ ILST = ILST - 1 + END IF + NBL = 1 + IF( ILST.LT.N ) THEN + IF( T( ILST+1, ILST ).NE.ZERO ) + $ NBL = 2 + END IF +* + IF( IFST.EQ.ILST ) + $ RETURN +* + IF( IFST.LT.ILST ) THEN +* +* Update ILST +* + IF( NBF.EQ.2 .AND. NBL.EQ.1 ) + $ ILST = ILST - 1 + IF( NBF.EQ.1 .AND. NBL.EQ.2 ) + $ ILST = ILST + 1 +* + HERE = IFST +* + 10 CONTINUE +* +* Swap block with next one below +* + IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN +* +* Current block either 1 by 1 or 2 by 2 +* + NBNEXT = 1 + IF( HERE+NBF+1.LE.N ) THEN + IF( T( HERE+NBF+1, HERE+NBF ).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBF, NBNEXT, + $ WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE + NBNEXT +* +* Test if 2 by 2 block breaks into two 1 by 1 blocks +* + IF( NBF.EQ.2 ) THEN + IF( T( HERE+1, HERE ).EQ.ZERO ) + $ NBF = 3 + END IF +* + ELSE +* +* Current block consists of two 1 by 1 blocks each of which +* must be swapped individually +* + NBNEXT = 1 + IF( HERE+3.LE.N ) THEN + IF( T( HERE+3, HERE+2 ).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, NBNEXT, + $ WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + IF( NBNEXT.EQ.1 ) THEN +* +* Swap two 1 by 1 blocks, no problems possible +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, NBNEXT, + $ WORK, INFO ) + HERE = HERE + 1 + ELSE +* +* Recompute NBNEXT in case 2 by 2 split +* + IF( T( HERE+2, HERE+1 ).EQ.ZERO ) + $ NBNEXT = 1 + IF( NBNEXT.EQ.2 ) THEN +* +* 2 by 2 Block did not split +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, + $ NBNEXT, WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE + 2 + ELSE +* +* 2 by 2 Block did split +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, + $ WORK, INFO ) + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, 1, + $ WORK, INFO ) + HERE = HERE + 2 + END IF + END IF + END IF + IF( HERE.LT.ILST ) + $ GO TO 10 +* + ELSE +* + HERE = IFST + 20 CONTINUE +* +* Swap block with next one above +* + IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN +* +* Current block either 1 by 1 or 2 by 2 +* + NBNEXT = 1 + IF( HERE.GE.3 ) THEN + IF( T( HERE-1, HERE-2 ).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, + $ NBF, WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE - NBNEXT +* +* Test if 2 by 2 block breaks into two 1 by 1 blocks +* + IF( NBF.EQ.2 ) THEN + IF( T( HERE+1, HERE ).EQ.ZERO ) + $ NBF = 3 + END IF +* + ELSE +* +* Current block consists of two 1 by 1 blocks each of which +* must be swapped individually +* + NBNEXT = 1 + IF( HERE.GE.3 ) THEN + IF( T( HERE-1, HERE-2 ).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, + $ 1, WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + IF( NBNEXT.EQ.1 ) THEN +* +* Swap two 1 by 1 blocks, no problems possible +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBNEXT, 1, + $ WORK, INFO ) + HERE = HERE - 1 + ELSE +* +* Recompute NBNEXT in case 2 by 2 split +* + IF( T( HERE, HERE-1 ).EQ.ZERO ) + $ NBNEXT = 1 + IF( NBNEXT.EQ.2 ) THEN +* +* 2 by 2 Block did not split +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 2, 1, + $ WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE - 2 + ELSE +* +* 2 by 2 Block did split +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, + $ WORK, INFO ) + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 1, 1, + $ WORK, INFO ) + HERE = HERE - 2 + END IF + END IF + END IF + IF( HERE.GT.ILST ) + $ GO TO 20 + END IF + ILST = HERE +* + RETURN +* +* End of DTREXC +* + END diff --git a/2.3-1/src/fortran/lapack/dtrsen.f b/2.3-1/src/fortran/lapack/dtrsen.f new file mode 100644 index 00000000..1d3ab03a --- /dev/null +++ b/2.3-1/src/fortran/lapack/dtrsen.f @@ -0,0 +1,459 @@ + SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, + $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER COMPQ, JOB + INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N + DOUBLE PRECISION S, SEP +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ), + $ WR( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, PAIR, SWAP, WANTBH, WANTQ, WANTS, + $ WANTSP + INTEGER IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2, + $ NN + DOUBLE PRECISION EST, RNORM, SCALE +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLANGE + EXTERNAL LSAME, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DLACPY, DTREXC, DTRSYL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + WANTBH = LSAME( JOB, 'B' ) + WANTS = LSAME( JOB, 'E' ) .OR. WANTBH + WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH + WANTQ = LSAME( COMPQ, 'V' ) +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP ) + $ THEN + INFO = -1 + ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN + INFO = -8 + ELSE +* +* Set M to the dimension of the specified invariant subspace, +* and test LWORK and LIWORK. +* + M = 0 + PAIR = .FALSE. + DO 10 K = 1, N + IF( PAIR ) THEN + PAIR = .FALSE. + ELSE + IF( K.LT.N ) THEN + IF( T( K+1, K ).EQ.ZERO ) THEN + IF( SELECT( K ) ) + $ M = M + 1 + ELSE + PAIR = .TRUE. + IF( SELECT( K ) .OR. SELECT( K+1 ) ) + $ M = M + 2 + END IF + ELSE + IF( SELECT( N ) ) + $ M = M + 1 + END IF + END IF + 10 CONTINUE +* + N1 = M + N2 = N - M + NN = N1*N2 +* + IF( WANTSP ) THEN + LWMIN = MAX( 1, 2*NN ) + LIWMIN = MAX( 1, NN ) + ELSE IF( LSAME( JOB, 'N' ) ) THEN + LWMIN = MAX( 1, N ) + LIWMIN = 1 + ELSE IF( LSAME( JOB, 'E' ) ) THEN + LWMIN = MAX( 1, NN ) + LIWMIN = 1 + END IF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -15 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -17 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTRSEN', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible. +* + IF( M.EQ.N .OR. M.EQ.0 ) THEN + IF( WANTS ) + $ S = ONE + IF( WANTSP ) + $ SEP = DLANGE( '1', N, N, T, LDT, WORK ) + GO TO 40 + END IF +* +* Collect the selected blocks at the top-left corner of T. +* + KS = 0 + PAIR = .FALSE. + DO 20 K = 1, N + IF( PAIR ) THEN + PAIR = .FALSE. + ELSE + SWAP = SELECT( K ) + IF( K.LT.N ) THEN + IF( T( K+1, K ).NE.ZERO ) THEN + PAIR = .TRUE. + SWAP = SWAP .OR. SELECT( K+1 ) + END IF + END IF + IF( SWAP ) THEN + KS = KS + 1 +* +* Swap the K-th block to position KS. +* + IERR = 0 + KK = K + IF( K.NE.KS ) + $ CALL DTREXC( COMPQ, N, T, LDT, Q, LDQ, KK, KS, WORK, + $ IERR ) + IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN +* +* Blocks too close to swap: exit. +* + INFO = 1 + IF( WANTS ) + $ S = ZERO + IF( WANTSP ) + $ SEP = ZERO + GO TO 40 + END IF + IF( PAIR ) + $ KS = KS + 1 + END IF + END IF + 20 CONTINUE +* + IF( WANTS ) THEN +* +* Solve Sylvester equation for R: +* +* T11*R - R*T22 = scale*T12 +* + CALL DLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 ) + CALL DTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ), + $ LDT, WORK, N1, SCALE, IERR ) +* +* Estimate the reciprocal of the condition number of the cluster +* of eigenvalues. +* + RNORM = DLANGE( 'F', N1, N2, WORK, N1, WORK ) + IF( RNORM.EQ.ZERO ) THEN + S = ONE + ELSE + S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )* + $ SQRT( RNORM ) ) + END IF + END IF +* + IF( WANTSP ) THEN +* +* Estimate sep(T11,T22). +* + EST = ZERO + KASE = 0 + 30 CONTINUE + CALL DLACN2( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN +* +* Solve T11*R - R*T22 = scale*X. +* + CALL DTRSYL( 'N', 'N', -1, N1, N2, T, LDT, + $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, + $ IERR ) + ELSE +* +* Solve T11'*R - R*T22' = scale*X. +* + CALL DTRSYL( 'T', 'T', -1, N1, N2, T, LDT, + $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, + $ IERR ) + END IF + GO TO 30 + END IF +* + SEP = SCALE / EST + END IF +* + 40 CONTINUE +* +* Store the output eigenvalues in WR and WI. +* + DO 50 K = 1, N + WR( K ) = T( K, K ) + WI( K ) = ZERO + 50 CONTINUE + DO 60 K = 1, N - 1 + IF( T( K+1, K ).NE.ZERO ) THEN + WI( K ) = SQRT( ABS( T( K, K+1 ) ) )* + $ SQRT( ABS( T( K+1, K ) ) ) + WI( K+1 ) = -WI( K ) + END IF + 60 CONTINUE +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of DTRSEN +* + END diff --git a/2.3-1/src/fortran/lapack/dtrsyl.f b/2.3-1/src/fortran/lapack/dtrsyl.f new file mode 100644 index 00000000..4c6c28e5 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dtrsyl.f @@ -0,0 +1,913 @@ + SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, + $ LDC, SCALE, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER TRANA, TRANB + INTEGER INFO, ISGN, LDA, LDB, LDC, M, N + DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRNA, NOTRNB + INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT + DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN, + $ SMLNUM, SUML, SUMR, XNORM +* .. +* .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT, DLAMCH, DLANGE + EXTERNAL LSAME, DDOT, DLAMCH, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, DLALN2, DLASY2, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOTRNA = LSAME( TRANA, 'N' ) + NOTRNB = LSAME( TRANB, 'N' ) +* + INFO = 0 + IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. + $ LSAME( TRANA, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT. + $ LSAME( TRANB, 'C' ) ) THEN + INFO = -2 + ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTRSYL', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Set constants to control overflow +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM*DBLE( M*N ) / EPS + BIGNUM = ONE / SMLNUM +* + SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', M, M, A, LDA, DUM ), + $ EPS*DLANGE( 'M', N, N, B, LDB, DUM ) ) +* + SCALE = ONE + SGN = ISGN +* + IF( NOTRNA .AND. NOTRNB ) THEN +* +* 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 + DO 60 L = 1, N + IF( L.LT.LNEXT ) + $ GO TO 60 + IF( L.EQ.N ) THEN + L1 = L + L2 = L + ELSE + IF( B( L+1, L ).NE.ZERO ) THEN + L1 = L + L2 = L + 1 + LNEXT = L + 2 + ELSE + L1 = L + L2 = L + LNEXT = L + 1 + END IF + END IF +* +* Start row loop (index = K) +* K1 (K2): row index of the first (last) row of X(K,L). +* + KNEXT = M + DO 50 K = M, 1, -1 + IF( K.GT.KNEXT ) + $ GO TO 50 + IF( K.EQ.1 ) THEN + K1 = K + K2 = K + ELSE + IF( A( K, K-1 ).NE.ZERO ) THEN + K1 = K - 1 + K2 = K + KNEXT = K - 2 + ELSE + K1 = K + K2 = K + KNEXT = K - 1 + END IF + END IF +* + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, + $ C( MIN( K1+1, M ), L1 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) + SCALOC = ONE +* + A11 = A( K1, K1 ) + SGN*B( L1, L1 ) + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +* + IF( SCALOC.NE.ONE ) THEN + DO 10 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 10 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) +* + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +* + SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, + $ C( MIN( K2+1, M ), L1 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) +* + SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, + $ C( MIN( K2+1, M ), L1 ), 1 ) + SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) +* + CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), + $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +* + IF( SCALOC.NE.ONE ) THEN + DO 20 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 20 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) +* + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +* + SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, + $ C( MIN( K1+1, M ), L1 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) + VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) +* + SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, + $ C( MIN( K1+1, M ), L2 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) + VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) +* + CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ), + $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +* + IF( SCALOC.NE.ONE ) THEN + DO 30 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 30 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) +* + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +* + SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, + $ C( MIN( K2+1, M ), L1 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) +* + SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, + $ C( MIN( K2+1, M ), L2 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) +* + SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, + $ C( MIN( K2+1, M ), L1 ), 1 ) + SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) +* + SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, + $ C( MIN( K2+1, M ), L2 ), 1 ) + SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) +* + CALL DLASY2( .FALSE., .FALSE., ISGN, 2, 2, + $ A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC, + $ 2, SCALOC, X, 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +* + IF( SCALOC.NE.ONE ) THEN + DO 40 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 40 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN +* +* 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 + DO 120 L = 1, N + IF( L.LT.LNEXT ) + $ GO TO 120 + IF( L.EQ.N ) THEN + L1 = L + L2 = L + ELSE + IF( B( L+1, L ).NE.ZERO ) THEN + L1 = L + L2 = L + 1 + LNEXT = L + 2 + ELSE + L1 = L + L2 = L + LNEXT = L + 1 + END IF + END IF +* +* Start row loop (index = K) +* K1 (K2): row index of the first (last) row of X(K,L) +* + KNEXT = 1 + DO 110 K = 1, M + IF( K.LT.KNEXT ) + $ GO TO 110 + IF( K.EQ.M ) THEN + K1 = K + K2 = K + ELSE + IF( A( K+1, K ).NE.ZERO ) THEN + K1 = K + K2 = K + 1 + KNEXT = K + 2 + ELSE + K1 = K + K2 = K + KNEXT = K + 1 + END IF + END IF +* + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) + SCALOC = ONE +* + A11 = A( K1, K1 ) + SGN*B( L1, L1 ) + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +* + IF( SCALOC.NE.ONE ) THEN + DO 70 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 70 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) +* + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +* + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) +* + SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) +* + CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), + $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +* + IF( SCALOC.NE.ONE ) THEN + DO 80 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 80 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) +* + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +* + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) + VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) +* + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) + VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) +* + CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ), + $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +* + IF( SCALOC.NE.ONE ) THEN + DO 90 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 90 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) +* + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +* + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) +* + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) +* + SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) +* + SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) + SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) +* + CALL DLASY2( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ), + $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, + $ 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +* + IF( SCALOC.NE.ONE ) THEN + DO 100 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 100 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + END IF +* + 110 CONTINUE + 120 CONTINUE +* + ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN +* +* 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 + DO 180 L = N, 1, -1 + IF( L.GT.LNEXT ) + $ GO TO 180 + IF( L.EQ.1 ) THEN + L1 = L + L2 = L + ELSE + IF( B( L, L-1 ).NE.ZERO ) THEN + L1 = L - 1 + L2 = L + LNEXT = L - 2 + ELSE + L1 = L + L2 = L + LNEXT = L - 1 + END IF + END IF +* +* Start row loop (index = K) +* K1 (K2): row index of the first (last) row of X(K,L) +* + KNEXT = 1 + DO 170 K = 1, M + IF( K.LT.KNEXT ) + $ GO TO 170 + IF( K.EQ.M ) THEN + K1 = K + K2 = K + ELSE + IF( A( K+1, K ).NE.ZERO ) THEN + K1 = K + K2 = K + 1 + KNEXT = K + 2 + ELSE + K1 = K + K2 = K + KNEXT = K + 1 + END IF + END IF +* + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC, + $ B( L1, MIN( L1+1, N ) ), LDB ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) + SCALOC = ONE +* + A11 = A( K1, K1 ) + SGN*B( L1, L1 ) + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +* + IF( SCALOC.NE.ONE ) THEN + DO 130 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 130 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) +* + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +* + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, + $ B( L1, MIN( L2+1, N ) ), LDB ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) +* + SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, + $ B( L1, MIN( L2+1, N ) ), LDB ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) +* + CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), + $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +* + IF( SCALOC.NE.ONE ) THEN + DO 140 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 140 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) +* + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +* + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, + $ B( L1, MIN( L2+1, N ) ), LDB ) + VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) +* + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, + $ B( L2, MIN( L2+1, N ) ), LDB ) + VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) +* + CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ), + $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +* + IF( SCALOC.NE.ONE ) THEN + DO 150 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 150 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) +* + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +* + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, + $ B( L1, MIN( L2+1, N ) ), LDB ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) +* + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, + $ B( L2, MIN( L2+1, N ) ), LDB ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) +* + SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, + $ B( L1, MIN( L2+1, N ) ), LDB ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) +* + SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) + SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, + $ B( L2, MIN( L2+1, N ) ), LDB ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) +* + CALL DLASY2( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ), + $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, + $ 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +* + IF( SCALOC.NE.ONE ) THEN + DO 160 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 160 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + END IF +* + 170 CONTINUE + 180 CONTINUE +* + ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN +* +* 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 + DO 240 L = N, 1, -1 + IF( L.GT.LNEXT ) + $ GO TO 240 + IF( L.EQ.1 ) THEN + L1 = L + L2 = L + ELSE + IF( B( L, L-1 ).NE.ZERO ) THEN + L1 = L - 1 + L2 = L + LNEXT = L - 2 + ELSE + L1 = L + L2 = L + LNEXT = L - 1 + END IF + END IF +* +* Start row loop (index = K) +* K1 (K2): row index of the first (last) row of X(K,L) +* + KNEXT = M + DO 230 K = M, 1, -1 + IF( K.GT.KNEXT ) + $ GO TO 230 + IF( K.EQ.1 ) THEN + K1 = K + K2 = K + ELSE + IF( A( K, K-1 ).NE.ZERO ) THEN + K1 = K - 1 + K2 = K + KNEXT = K - 2 + ELSE + K1 = K + K2 = K + KNEXT = K - 1 + END IF + END IF +* + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, + $ C( MIN( K1+1, M ), L1 ), 1 ) + SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC, + $ B( L1, MIN( L1+1, N ) ), LDB ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) + SCALOC = ONE +* + A11 = A( K1, K1 ) + SGN*B( L1, L1 ) + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +* + IF( SCALOC.NE.ONE ) THEN + DO 190 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 190 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) +* + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +* + SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, + $ C( MIN( K2+1, M ), L1 ), 1 ) + SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, + $ B( L1, MIN( L2+1, N ) ), LDB ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) +* + SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, + $ C( MIN( K2+1, M ), L1 ), 1 ) + SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, + $ B( L1, MIN( L2+1, N ) ), LDB ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) +* + CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), + $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +* + IF( SCALOC.NE.ONE ) THEN + DO 200 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 200 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) +* + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +* + SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, + $ C( MIN( K1+1, M ), L1 ), 1 ) + SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, + $ B( L1, MIN( L2+1, N ) ), LDB ) + VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) +* + SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, + $ C( MIN( K1+1, M ), L2 ), 1 ) + SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, + $ B( L2, MIN( L2+1, N ) ), LDB ) + VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) +* + CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ), + $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +* + IF( SCALOC.NE.ONE ) THEN + DO 210 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 210 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) +* + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +* + SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, + $ C( MIN( K2+1, M ), L1 ), 1 ) + SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, + $ B( L1, MIN( L2+1, N ) ), LDB ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) +* + SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, + $ C( MIN( K2+1, M ), L2 ), 1 ) + SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, + $ B( L2, MIN( L2+1, N ) ), LDB ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) +* + SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, + $ C( MIN( K2+1, M ), L1 ), 1 ) + SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, + $ B( L1, MIN( L2+1, N ) ), LDB ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) +* + SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, + $ C( MIN( K2+1, M ), L2 ), 1 ) + SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, + $ B( L2, MIN( L2+1, N ) ), LDB ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) +* + CALL DLASY2( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ), + $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, + $ 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +* + IF( SCALOC.NE.ONE ) THEN + DO 220 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 220 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + END IF +* + 230 CONTINUE + 240 CONTINUE +* + END IF +* + RETURN +* +* End of DTRSYL +* + END diff --git a/2.3-1/src/fortran/lapack/dtrti2.f b/2.3-1/src/fortran/lapack/dtrti2.f new file mode 100644 index 00000000..e7ae764d --- /dev/null +++ b/2.3-1/src/fortran/lapack/dtrti2.f @@ -0,0 +1,146 @@ + SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIAG, UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT, UPPER + INTEGER J + DOUBLE PRECISION AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DTRMV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + NOUNIT = LSAME( DIAG, 'N' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTRTI2', -INFO ) + RETURN + END IF +* + IF( UPPER ) THEN +* +* Compute inverse of upper triangular matrix. +* + DO 10 J = 1, N + IF( NOUNIT ) THEN + A( J, J ) = ONE / A( J, J ) + AJJ = -A( J, J ) + ELSE + AJJ = -ONE + END IF +* +* Compute elements 1:j-1 of j-th column. +* + CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, + $ A( 1, J ), 1 ) + CALL DSCAL( J-1, AJJ, A( 1, J ), 1 ) + 10 CONTINUE + ELSE +* +* Compute inverse of lower triangular matrix. +* + DO 20 J = N, 1, -1 + IF( NOUNIT ) THEN + A( J, J ) = ONE / A( J, J ) + AJJ = -A( J, J ) + ELSE + AJJ = -ONE + END IF + IF( J.LT.N ) THEN +* +* Compute elements j+1:n of j-th column. +* + CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J, + $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) + CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 ) + END IF + 20 CONTINUE + END IF +* + RETURN +* +* End of DTRTI2 +* + END diff --git a/2.3-1/src/fortran/lapack/dtrtri.f b/2.3-1/src/fortran/lapack/dtrtri.f new file mode 100644 index 00000000..375813c6 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dtrtri.f @@ -0,0 +1,176 @@ + SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIAG, UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT, UPPER + INTEGER J, JB, NB, NN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + NOUNIT = LSAME( DIAG, 'N' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTRTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Check for singularity if non-unit. +* + IF( NOUNIT ) THEN + DO 10 INFO = 1, N + IF( A( INFO, INFO ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + INFO = 0 + END IF +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) + ELSE +* +* Use blocked code +* + IF( UPPER ) THEN +* +* Compute inverse of upper triangular matrix +* + DO 20 J = 1, N, NB + JB = MIN( NB, N-J+1 ) +* +* Compute rows 1:j-1 of current block column +* + CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, + $ JB, ONE, A, LDA, A( 1, J ), LDA ) + CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, + $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) +* +* Compute inverse of current diagonal block +* + CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) + 20 CONTINUE + ELSE +* +* Compute inverse of lower triangular matrix +* + NN = ( ( N-1 ) / NB )*NB + 1 + DO 30 J = NN, 1, -NB + JB = MIN( NB, N-J+1 ) + IF( J+JB.LE.N ) THEN +* +* Compute rows j+jb:n of current block column +* + CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG, + $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, + $ A( J+JB, J ), LDA ) + CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG, + $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, + $ A( J+JB, J ), LDA ) + END IF +* +* Compute inverse of current diagonal block +* + CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) + 30 CONTINUE + END IF + END IF +* + RETURN +* +* End of DTRTRI +* + END diff --git a/2.3-1/src/fortran/lapack/dtrtrs.f b/2.3-1/src/fortran/lapack/dtrtrs.f new file mode 100644 index 00000000..139ea6d4 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dtrtrs.f @@ -0,0 +1,147 @@ + SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, + $ INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIAG, TRANS, UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NOUNIT = LSAME( DIAG, 'N' ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT. + $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTRTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Check for singularity. +* + IF( NOUNIT ) THEN + DO 10 INFO = 1, N + IF( A( INFO, INFO ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + END IF + INFO = 0 +* +* Solve A * x = b or A' * x = b. +* + CALL DTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B, + $ LDB ) +* + RETURN +* +* End of DTRTRS +* + END diff --git a/2.3-1/src/fortran/lapack/dtzrqf.f b/2.3-1/src/fortran/lapack/dtzrqf.f new file mode 100644 index 00000000..5555df38 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dtzrqf.f @@ -0,0 +1,164 @@ + SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K, M1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLARFG, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.M ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTZRQF', -INFO ) + RETURN + END IF +* +* Perform the factorization. +* + IF( M.EQ.0 ) + $ RETURN + IF( M.EQ.N ) THEN + DO 10 I = 1, N + TAU( I ) = ZERO + 10 CONTINUE + ELSE + M1 = MIN( M+1, N ) + DO 20 K = M, 1, -1 +* +* Use a Householder reflection to zero the kth row of A. +* First set up the reflection. +* + CALL DLARFG( N-M+1, A( K, K ), A( K, M1 ), LDA, TAU( K ) ) +* + IF( ( TAU( K ).NE.ZERO ) .AND. ( K.GT.1 ) ) THEN +* +* 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. +* + CALL DCOPY( K-1, A( 1, K ), 1, TAU, 1 ) +* +* Form w = a( k ) + B*z( k ) in TAU. +* + CALL DGEMV( 'No transpose', K-1, N-M, ONE, A( 1, M1 ), + $ LDA, A( K, M1 ), LDA, ONE, TAU, 1 ) +* +* Now form a( k ) := a( k ) - tau*w +* and B := B - tau*w*z( k )'. +* + CALL DAXPY( K-1, -TAU( K ), TAU, 1, A( 1, K ), 1 ) + CALL DGER( K-1, N-M, -TAU( K ), TAU, 1, A( K, M1 ), LDA, + $ A( 1, M1 ), LDA ) + END IF + 20 CONTINUE + END IF +* + RETURN +* +* End of DTZRQF +* + END diff --git a/2.3-1/src/fortran/lapack/dtzrzf.f b/2.3-1/src/fortran/lapack/dtzrzf.f new file mode 100644 index 00000000..378eefe1 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dtzrzf.f @@ -0,0 +1,244 @@ + SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IWS, KI, KK, LDWORK, LWKOPT, M1, MU, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DLARZB, DLARZT, DLATRZ, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.M ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( M.EQ.0 .OR. M.EQ.N ) THEN + LWKOPT = 1 + ELSE +* +* Determine the block size. +* + NB = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 ) + LWKOPT = M*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTZRZF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 ) THEN + RETURN + ELSE IF( M.EQ.N ) THEN + DO 10 I = 1, N + TAU( I ) = ZERO + 10 CONTINUE + RETURN + END IF +* + NBMIN = 2 + NX = 1 + IWS = M + IF( NB.GT.1 .AND. NB.LT.M ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DGERQF', ' ', M, N, -1, -1 ) ) + IF( NX.LT.M ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = M + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DGERQF', ' ', M, N, -1, + $ -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.M .AND. NX.LT.M ) THEN +* +* Use blocked code initially. +* The last kk rows are handled by the block method. +* + M1 = MIN( M+1, N ) + KI = ( ( M-NX-1 ) / NB )*NB + KK = MIN( M, KI+NB ) +* + DO 20 I = M - KK + KI + 1, M - KK + 1, -NB + IB = MIN( M-I+1, NB ) +* +* Compute the TZ factorization of the current block +* A(i:i+ib-1,i:n) +* + CALL DLATRZ( IB, N-I+1, N-M, A( I, I ), LDA, TAU( I ), + $ WORK ) + IF( I.GT.1 ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i+ib-1) . . . H(i+1) H(i) +* + CALL DLARZT( 'Backward', 'Rowwise', N-M, IB, A( I, M1 ), + $ LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(1:i-1,i:n) from the right +* + CALL DLARZB( 'Right', 'No transpose', 'Backward', + $ 'Rowwise', I-1, N-I+1, IB, N-M, A( I, M1 ), + $ LDA, WORK, LDWORK, A( 1, I ), LDA, + $ WORK( IB+1 ), LDWORK ) + END IF + 20 CONTINUE + MU = I + NB - 1 + ELSE + MU = M + END IF +* +* Use unblocked code to factor the last or only block +* + IF( MU.GT.0 ) + $ CALL DLATRZ( MU, N, N-M, A, LDA, TAU, WORK ) +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DTZRZF +* + END diff --git a/2.3-1/src/fortran/lapack/dzsum1.f b/2.3-1/src/fortran/lapack/dzsum1.f new file mode 100644 index 00000000..0b6c60e7 --- /dev/null +++ b/2.3-1/src/fortran/lapack/dzsum1.f @@ -0,0 +1,81 @@ + DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, N +* .. +* .. Array Arguments .. + COMPLEX*16 CX( * ) +* .. +* +* 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 .. + INTEGER I, NINCX + DOUBLE PRECISION STEMP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + DZSUM1 = 0.0D0 + STEMP = 0.0D0 + IF( N.LE.0 ) + $ RETURN + IF( INCX.EQ.1 ) + $ GO TO 20 +* +* CODE FOR INCREMENT NOT EQUAL TO 1 +* + NINCX = N*INCX + DO 10 I = 1, NINCX, INCX +* +* NEXT LINE MODIFIED. +* + STEMP = STEMP + ABS( CX( I ) ) + 10 CONTINUE + DZSUM1 = STEMP + RETURN +* +* CODE FOR INCREMENT EQUAL TO 1 +* + 20 CONTINUE + DO 30 I = 1, N +* +* NEXT LINE MODIFIED. +* + STEMP = STEMP + ABS( CX( I ) ) + 30 CONTINUE + DZSUM1 = STEMP + RETURN +* +* End of DZSUM1 +* + END diff --git a/2.3-1/src/fortran/lapack/ieeeck.f b/2.3-1/src/fortran/lapack/ieeeck.f new file mode 100644 index 00000000..ac4aff85 --- /dev/null +++ b/2.3-1/src/fortran/lapack/ieeeck.f @@ -0,0 +1,147 @@ + INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER ISPEC + REAL ONE, ZERO +* .. +* +* 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 .. + REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, + $ NEGZRO, NEWZRO, POSINF +* .. +* .. Executable Statements .. + IEEECK = 1 +* + POSINF = ONE / ZERO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = -ONE / ZERO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGZRO = ONE / ( NEGINF+ONE ) + IF( NEGZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = ONE / NEGZRO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEWZRO = NEGZRO + ZERO + IF( NEWZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = ONE / NEWZRO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = NEGINF*POSINF + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = POSINF*POSINF + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* +* +* +* +* Return if we were only asked to check infinity arithmetic +* + IF( ISPEC.EQ.0 ) + $ RETURN +* + NAN1 = POSINF + NEGINF +* + NAN2 = POSINF / NEGINF +* + NAN3 = POSINF / POSINF +* + NAN4 = POSINF*ZERO +* + NAN5 = NEGINF*NEGZRO +* + NAN6 = NAN5*0.0 +* + IF( NAN1.EQ.NAN1 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN2.EQ.NAN2 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN3.EQ.NAN3 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN4.EQ.NAN4 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN5.EQ.NAN5 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN6.EQ.NAN6 ) THEN + IEEECK = 0 + RETURN + END IF +* + RETURN + END diff --git a/2.3-1/src/fortran/lapack/ilaenv.f b/2.3-1/src/fortran/lapack/ilaenv.f new file mode 100644 index 00000000..c375031b --- /dev/null +++ b/2.3-1/src/fortran/lapack/ilaenv.f @@ -0,0 +1,552 @@ + INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* 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 (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. +* +* (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 .. + INTEGER I, IC, IZ, NB, NBMIN, NX + LOGICAL CNAME, SNAME + CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 +* .. +* .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, INT, MIN, REAL +* .. +* .. External Functions .. + INTEGER IEEECK, IPARMQ + EXTERNAL IEEECK, IPARMQ +* .. +* .. Executable Statements .. +* + GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, + $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC +* +* Invalid value for ISPEC +* + ILAENV = -1 + RETURN +* + 10 CONTINUE +* +* Convert NAME to upper case if the first character is lower case. +* + ILAENV = 1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 20 CONTINUE + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + 30 CONTINUE + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 40 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 40 CONTINUE + END IF + END IF +* + C1 = SUBNAM( 1: 1 ) + SNAME = C1.EQ.'S' .OR. C1.EQ.'D' + CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' + IF( .NOT.( CNAME .OR. SNAME ) ) + $ RETURN + C2 = SUBNAM( 2: 3 ) + C3 = SUBNAM( 4: 6 ) + C4 = C3( 2: 3 ) +* + GO TO ( 50, 60, 70 )ISPEC +* + 50 CONTINUE +* +* 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( C2.EQ.'GE' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'PO' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRF' ) THEN + NB = 64 + ELSE IF( C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( C2.EQ.'GB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'PB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'TR' ) THEN + IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'LA' ) THEN + IF( C3.EQ.'UUM' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN + IF( C3.EQ.'EBZ' ) THEN + NB = 1 + END IF + END IF + ILAENV = NB + RETURN +* + 60 CONTINUE +* +* ISPEC = 2: minimum block size +* + NBMIN = 2 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NBMIN = 8 + ELSE + NBMIN = 8 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + END IF + ILAENV = NBMIN + RETURN +* + 70 CONTINUE +* +* ISPEC = 3: crossover point +* + NX = 0 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + END IF + ILAENV = NX + RETURN +* + 80 CONTINUE +* +* ISPEC = 4: number of shifts (used by xHSEQR) +* + ILAENV = 6 + RETURN +* + 90 CONTINUE +* +* ISPEC = 5: minimum column dimension (not used) +* + ILAENV = 2 + RETURN +* + 100 CONTINUE +* +* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) +* + ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) + RETURN +* + 110 CONTINUE +* +* ISPEC = 7: number of processors (not used) +* + ILAENV = 1 + RETURN +* + 120 CONTINUE +* +* ISPEC = 8: crossover point for multishift (used by xHSEQR) +* + ILAENV = 50 + RETURN +* + 130 CONTINUE +* +* 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) +* + ILAENV = 25 + RETURN +* + 140 CONTINUE +* +* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 0, 0.0, 1.0 ) + END IF + RETURN +* + 150 CONTINUE +* +* ISPEC = 11: infinity arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 1, 0.0, 1.0 ) + END IF + RETURN +* + 160 CONTINUE +* +* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. +* + ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + RETURN +* +* End of ILAENV +* + END diff --git a/2.3-1/src/fortran/lapack/iparmq.f b/2.3-1/src/fortran/lapack/iparmq.f new file mode 100644 index 00000000..d9d0af36 --- /dev/null +++ b/2.3-1/src/fortran/lapack/iparmq.f @@ -0,0 +1,253 @@ + INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, ISPEC, LWORK, N + CHARACTER NAME*( * ), OPTS*( * ) +* +* 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 .. + INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 + PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, + $ ISHFTS = 15, IACC22 = 16 ) + INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP + PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, + $ NIBBLE = 14, KNWSWP = 500 ) + REAL TWO + PARAMETER ( TWO = 2.0 ) +* .. +* .. Local Scalars .. + INTEGER NH, NS +* .. +* .. Intrinsic Functions .. + INTRINSIC LOG, MAX, MOD, NINT, REAL +* .. +* .. Executable Statements .. + IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. + $ ( ISPEC.EQ.IACC22 ) ) THEN +* +* ==== Set the number simultaneous shifts ==== +* + NH = IHI - ILO + 1 + NS = 2 + IF( NH.GE.30 ) + $ NS = 4 + IF( NH.GE.60 ) + $ NS = 10 + IF( NH.GE.150 ) + $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) + IF( NH.GE.590 ) + $ NS = 64 + IF( NH.GE.3000 ) + $ NS = 128 + IF( NH.GE.6000 ) + $ NS = 256 + NS = MAX( 2, NS-MOD( NS, 2 ) ) + END IF +* + IF( ISPEC.EQ.INMIN ) THEN +* +* +* ===== Matrices of order smaller than NMIN get sent +* . to xLAHQR, the classic double shift algorithm. +* . This must be at least 11. ==== +* + IPARMQ = NMIN +* + ELSE IF( ISPEC.EQ.INIBL ) THEN +* +* ==== INIBL: skip a multi-shift qr iteration and +* . whenever aggressive early deflation finds +* . at least (NIBBLE*(window size)/100) deflations. ==== +* + IPARMQ = NIBBLE +* + ELSE IF( ISPEC.EQ.ISHFTS ) THEN +* +* ==== NSHFTS: The number of simultaneous shifts ===== +* + IPARMQ = NS +* + ELSE IF( ISPEC.EQ.INWIN ) THEN +* +* ==== NW: deflation window size. ==== +* + IF( NH.LE.KNWSWP ) THEN + IPARMQ = NS + ELSE + IPARMQ = 3*NS / 2 + END IF +* + ELSE IF( ISPEC.EQ.IACC22 ) THEN +* +* ==== 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. +* + IPARMQ = 0 + IF( NS.GE.KACMIN ) + $ IPARMQ = 1 + IF( NS.GE.K22MIN ) + $ IPARMQ = 2 +* + ELSE +* ===== invalid value of ispec ===== + IPARMQ = -1 +* + END IF +* +* ==== End of IPARMQ ==== +* + END diff --git a/2.3-1/src/fortran/lapack/izmax1.f b/2.3-1/src/fortran/lapack/izmax1.f new file mode 100644 index 00000000..7ebffee3 --- /dev/null +++ b/2.3-1/src/fortran/lapack/izmax1.f @@ -0,0 +1,95 @@ + INTEGER FUNCTION IZMAX1( N, CX, INCX ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, N +* .. +* .. Array Arguments .. + COMPLEX*16 CX( * ) +* .. +* +* 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 .. + INTEGER I, IX + DOUBLE PRECISION SMAX + COMPLEX*16 ZDUM +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. +* +* NEXT LINE IS THE ONLY MODIFICATION. + CABS1( ZDUM ) = ABS( ZDUM ) +* .. +* .. Executable Statements .. +* + IZMAX1 = 0 + IF( N.LT.1 ) + $ RETURN + IZMAX1 = 1 + IF( N.EQ.1 ) + $ RETURN + IF( INCX.EQ.1 ) + $ GO TO 30 +* +* CODE FOR INCREMENT NOT EQUAL TO 1 +* + IX = 1 + SMAX = CABS1( CX( 1 ) ) + IX = IX + INCX + DO 20 I = 2, N + IF( CABS1( CX( IX ) ).LE.SMAX ) + $ GO TO 10 + IZMAX1 = I + SMAX = CABS1( CX( IX ) ) + 10 CONTINUE + IX = IX + INCX + 20 CONTINUE + RETURN +* +* CODE FOR INCREMENT EQUAL TO 1 +* + 30 CONTINUE + SMAX = CABS1( CX( 1 ) ) + DO 40 I = 2, N + IF( CABS1( CX( I ) ).LE.SMAX ) + $ GO TO 40 + IZMAX1 = I + SMAX = CABS1( CX( I ) ) + 40 CONTINUE + RETURN +* +* End of IZMAX1 +* + END diff --git a/2.3-1/src/fortran/lapack/lapack_f/lapack.def b/2.3-1/src/fortran/lapack/lapack_f/lapack.def new file mode 100644 index 00000000..a6ce5165 --- /dev/null +++ b/2.3-1/src/fortran/lapack/lapack_f/lapack.def @@ -0,0 +1,306 @@ +LIBRARY lapack.dll + + +EXPORTS + dbdsqr_ + dgebak_ + dgebal_ + dgebd2_ + dgebrd_ + dgecon_ + dgeequ_ + dgees_ + dgeesx_ + dgeev_ + dgegs_ + dgehd2_ + dgehrd_ + dgelq2_ + dgelqf_ + dgels_ + dgelss_ + dgelsx_ + dgelsy_ + dgeql2_ + dgeqlf_ + dgeqp3_ + dgeqpf_ + dgeqr2_ + dgeqrf_ + dgerfs_ + dgerq2_ + dgerqf_ + dgesc2_ + dgesv_ + dgesvd_ + dgesvx_ + dgetc2_ + dgetf2_ + dgetrf_ + dgetri_ + dgetrs_ + dggbak_ + dggbal_ + dgges_ + dggev_ + dgghrd_ + dhgeqz_ + dhseqr_ + disnan_ + dlabad_ + dlabrd_ + dlacn2_ + dlacon_ + dlacpy_ + dladiv_ + dlae2_ + dlaev2_ + dlaexc_ + dlag2_ + dlagv2_ + dlahqr_ + dlahr2_ + dlahrd_ + dlaic1_ + dlaisnan_ + dlaln2_ + dlamch_ + dlamc2_ + dlamc1_ + dlamc3_ + dlamc4_ + dlamc5_ + dlange_ + dlanhs_ + dlansp_ + dlanst_ + dlansy_ + dlantr_ + dlanv2_ + dlapmt_ + dlapy2_ + dlapy3_ + dlaqge_ + dlaqp2_ + dlaqps_ + dlaqr0_ + dlaqr1_ + dlaqr2_ + dlaqr3_ + dlaqr4_ + dlaqr5_ + dlarf_ + dlarfb_ + dlarfg_ + dlarft_ + dlarfx_ + dlartg_ + dlarz_ + dlarzb_ + dlarzt_ + dlas2_ + dlascl_ + dlaset_ + dlasq1_ + dlasq2_ + dlasq3_ + dlasq4_ + dlasq5_ + dlasq6_ + dlasr_ + dlasrt_ + dlassq_ + dlasv2_ + dlaswp_ + dlasy2_ + dlasyf_ + dlatdf_ + dlatrd_ + dlatrs_ + dlatrz_ + dlatzm_ + dlazq3_ + dlazq4_ + dopgtr_ + dorg2l_ + dorg2r_ + dorgbr_ + dorghr_ + dorgl2_ + dorglq_ + dorgql_ + dorgqr_ + dorgr2_ + dorgrq_ + dorgtr_ + dorm2l_ + dorm2r_ + dormbr_ + dormhr_ + dorml2_ + dormlq_ + dormql_ + dormqr_ + dormr2_ + dormr3_ + dormrq_ + dormrz_ + dpocon_ + dpotf2_ + dpotrf_ + dpotrs_ + dpptrf_ + drscl_ + dspev_ + dspgst_ + dspgv_ + dsptrd_ + dsptrf_ + dsteqr_ + dsterf_ + dsycon_ + dsyev_ + dsysv_ + dsytd2_ + dsytf2_ + dsytrd_ + dsytrf_ + dsytri_ + dsytrs_ + dtgevc_ + dtgex2_ + dtgexc_ + dtgsen_ + dtgsy2_ + dtgsyl_ + dtrcon_ + dtrevc_ + dtrexc_ + dtrsen_ + dtrsyl_ + dtrti2_ + dtrtri_ + dtrtrs_ + dtzrqf_ + dtzrzf_ + dzsum1_ + ieeeck_ + ilaenv_ + iparmq_ + izmax1_ + lsame_ + slamch_ + slamc2_ + slamc1_ + slamc3_ + slamc4_ + slamc5_ + zbdsqr_ + zdrot_ + zdrscl_ + zgebak_ + zgebal_ + zgebd2_ + zgebrd_ + zgecon_ + zgees_ + zgeev_ + zgehd2_ + zgehrd_ + zgelq2_ + zgelqf_ + zgelsy_ + zgeqp3_ + zgeqpf_ + zgeqr2_ + zgeqrf_ + zgesc2_ + zgesvd_ + zgetc2_ + zgetf2_ + zgetrf_ + zgetri_ + zgetrs_ + zggbak_ + zggbal_ + zgges_ + zggev_ + zgghrd_ + zheev_ + zhetd2_ + zhetrd_ + zhgeqz_ + zhseqr_ + zlabrd_ + zlacgv_ + zlacn2_ + zlacon_ + zlacpy_ + zladiv_ + zlahqr_ + zlahr2_ + zlahrd_ + zlaic1_ + zlange_ + zlanhe_ + zlanhs_ + zlaqp2_ + zlaqps_ + zlaqr0_ + zlaqr1_ + zlaqr2_ + zlaqr3_ + zlaqr4_ + zlaqr5_ + zlarf_ + zlarfb_ + zlarfg_ + zlarft_ + zlarfx_ + zlartg_ + zlarz_ + zlarzb_ + zlarzt_ + zlascl_ + zlaset_ + zlasr_ + zlassq_ + zlaswp_ + zlatdf_ + zlatrd_ + zlatrs_ + zlatrz_ + zpotf2_ + zpotrf_ + zrot_ + zsteqr_ + ztgevc_ + ztgex2_ + ztgexc_ + ztgsen_ + ztgsy2_ + ztgsyl_ + ztrevc_ + ztrexc_ + ztrsen_ + ztrsyl_ + ztrti2_ + ztrtri_ + ztzrzf_ + zung2l_ + zung2r_ + zungbr_ + zunghr_ + zungl2_ + zunglq_ + zungql_ + zungqr_ + zungtr_ + zunm2r_ + zunmbr_ + zunml2_ + zunmlq_ + zunmqr_ + zunmr3_ + zunmrz_ + \ No newline at end of file diff --git a/2.3-1/src/fortran/lapack/lapack_f/lapack_DLL.suo b/2.3-1/src/fortran/lapack/lapack_f/lapack_DLL.suo new file mode 100644 index 00000000..156fa9f3 Binary files /dev/null and b/2.3-1/src/fortran/lapack/lapack_f/lapack_DLL.suo differ diff --git a/2.3-1/src/fortran/lapack/lapack_f/lapack_DLL.vfproj b/2.3-1/src/fortran/lapack/lapack_f/lapack_DLL.vfproj new file mode 100644 index 00000000..41c7a411 --- /dev/null +++ b/2.3-1/src/fortran/lapack/lapack_f/lapack_DLL.vfproj @@ -0,0 +1,352 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/2.3-1/src/fortran/lapack/lapack_f/lapack_DLL_f2c.vcxproj b/2.3-1/src/fortran/lapack/lapack_f/lapack_DLL_f2c.vcxproj new file mode 100644 index 00000000..51d00d60 --- /dev/null +++ b/2.3-1/src/fortran/lapack/lapack_f/lapack_DLL_f2c.vcxproj @@ -0,0 +1,837 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + lapack_f2c_DLL + {69296D00-0DE1-4F4B-B0CE-FE4F3CB43923} + lapack_f2c_DLL + Win32Proj + + + + DynamicLibrary + MultiByte + + + DynamicLibrary + MultiByte + + + DynamicLibrary + MultiByte + + + DynamicLibrary + MultiByte + + + + + + + + + + + + + + + + + + + + <_ProjectFileVersion>10.0.40219.1 + $(SolutionDir)bin\ + $(ProjectDir)$(Configuration)\ + $(SolutionDir)bin\ + $(ProjectDir)$(Configuration)\ + $(SolutionDir)bin\ + $(ProjectDir)$(Configuration)\ + $(SolutionDir)bin\ + $(ProjectDir)$(Configuration)\ + + + + + + + + Disabled + ../../f2c;%(AdditionalIncludeDirectories) + STRICT;__STDC__;_CRT_SECURE_NO_DEPRECATE;%(PreprocessorDefinitions) + true + Default + MultiThreadedDebug + + + $(Configuration)/ + $(Configuration)/vc80.pdb + Level3 + ProgramDatabase + + + Build Lapack.def file + + + + + /fixed:no %(AdditionalOptions) + $(SolutionDir)bin\lapack.dll + lapack.def + false + + + $(SolutionDir)bin\$(TargetName).lib + true + + + + + + + + + + + + + X64 + + + Disabled + ../../f2c;%(AdditionalIncludeDirectories) + STRICT;__STDC__;_CRT_SECURE_NO_DEPRECATE;%(PreprocessorDefinitions) + true + Default + MultiThreadedDebug + + + $(Configuration)/ + $(Configuration)/vc80.pdb + Level3 + ProgramDatabase + + + Build Lapack.def file + + + + + /fixed:no %(AdditionalOptions) + ../../../bin/lapack.dll + lapack.def + false + + + MachineX64 + true + + + + + + + + + + + + + Speed + ../../f2c;%(AdditionalIncludeDirectories) + STRICT;__STDC__;_CRT_SECURE_NO_DEPRECATE;%(PreprocessorDefinitions) + MultiThreaded + NotSet + + + $(Configuration)/ + $(Configuration)/vc80.pdb + Level3 + ProgramDatabase + + + Build Lapack.def file + + + + + $(SolutionDir)bin\lapack.dll + lapack.def + false + + + $(SolutionDir)bin\$(TargetName).lib + true + + + + + + + + + + + + + X64 + + + Speed + ../../f2c;%(AdditionalIncludeDirectories) + STRICT;__STDC__;_CRT_SECURE_NO_DEPRECATE;%(PreprocessorDefinitions) + MultiThreaded + StreamingSIMDExtensions + + + $(Configuration)/ + $(Configuration)/vc80.pdb + Level3 + ProgramDatabase + + + Build Lapack.def file + + + + + ../../../bin/lapack.dll + lapack.def + false + + + MachineX64 + true + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Disabled + Disabled + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + {78bd64ce-181d-4d3f-9254-5c4f55c1edc9} + false + + + + + + + \ No newline at end of file diff --git a/2.3-1/src/fortran/lapack/lapack_f/lapack_DLL_f2c.vcxproj.filters b/2.3-1/src/fortran/lapack/lapack_f/lapack_DLL_f2c.vcxproj.filters new file mode 100644 index 00000000..7a89de81 --- /dev/null +++ b/2.3-1/src/fortran/lapack/lapack_f/lapack_DLL_f2c.vcxproj.filters @@ -0,0 +1,1782 @@ + + + + + {3b906b2b-f90a-45f4-a2ca-d4606665aae9} + cpp;c;cxx;def;odl;idl;hpj;bat;asm;asmx + + + {2d444260-4b18-4321-b33c-befb73e5eea2} + h;hpp;hxx;hm;inl;inc;xsd + + + {192f4d41-c71c-4794-a1e0-cdf9729470c1} + rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx + + + {de2dcb15-7a52-47c0-b7de-4fe911ee4029} + + + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + Fortran Files + + + + + + + + + \ No newline at end of file diff --git a/2.3-1/src/fortran/lapack/lsame.f b/2.3-1/src/fortran/lapack/lsame.f new file mode 100644 index 00000000..bf25d86f --- /dev/null +++ b/2.3-1/src/fortran/lapack/lsame.f @@ -0,0 +1,87 @@ + LOGICAL FUNCTION LSAME( CA, CB ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* September 30, 1994 +* +* .. Scalar Arguments .. + CHARACTER CA, CB +* .. +* +* 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 .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA, INTB, ZCODE +* .. +* .. Executable Statements .. +* +* Test if the characters are equal +* + LSAME = CA.EQ.CB + IF( LSAME ) + $ RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + ZCODE = ICHAR( '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 = ICHAR( CA ) + INTB = ICHAR( CB ) +* + IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 + IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 +* + ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF( INTA.GE.129 .AND. INTA.LE.137 .OR. + $ INTA.GE.145 .AND. INTA.LE.153 .OR. + $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 + IF( INTB.GE.129 .AND. INTB.LE.137 .OR. + $ INTB.GE.145 .AND. INTB.LE.153 .OR. + $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 +* + ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 + IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 + END IF + LSAME = INTA.EQ.INTB +* +* RETURN +* +* End of LSAME +* + END diff --git a/2.3-1/src/fortran/lapack/slamch.f b/2.3-1/src/fortran/lapack/slamch.f new file mode 100644 index 00000000..afb4d368 --- /dev/null +++ b/2.3-1/src/fortran/lapack/slamch.f @@ -0,0 +1,857 @@ + REAL FUNCTION SLAMCH( CMACH ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + CHARACTER CMACH +* .. +* +* 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 .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL FIRST, LRND + INTEGER BETA, IMAX, IMIN, IT + REAL BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, + $ RND, SFMIN, SMALL, T +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SLAMC2 +* .. +* .. Save statement .. + SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, + $ EMAX, RMAX, PREC +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + CALL SLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) + BASE = BETA + T = IT + IF( LRND ) THEN + RND = ONE + EPS = ( BASE**( 1-IT ) ) / 2 + ELSE + RND = ZERO + EPS = BASE**( 1-IT ) + END IF + PREC = EPS*BASE + EMIN = IMIN + EMAX = IMAX + SFMIN = RMIN + SMALL = ONE / RMAX + IF( SMALL.GE.SFMIN ) THEN +* +* Use SMALL plus a bit, to avoid the possibility of rounding +* causing overflow when computing 1/sfmin. +* + SFMIN = SMALL*( ONE+EPS ) + END IF + END IF +* + IF( LSAME( CMACH, 'E' ) ) THEN + RMACH = EPS + ELSE IF( LSAME( CMACH, 'S' ) ) THEN + RMACH = SFMIN + ELSE IF( LSAME( CMACH, 'B' ) ) THEN + RMACH = BASE + ELSE IF( LSAME( CMACH, 'P' ) ) THEN + RMACH = PREC + ELSE IF( LSAME( CMACH, 'N' ) ) THEN + RMACH = T + ELSE IF( LSAME( CMACH, 'R' ) ) THEN + RMACH = RND + ELSE IF( LSAME( CMACH, 'M' ) ) THEN + RMACH = EMIN + ELSE IF( LSAME( CMACH, 'U' ) ) THEN + RMACH = RMIN + ELSE IF( LSAME( CMACH, 'L' ) ) THEN + RMACH = EMAX + ELSE IF( LSAME( CMACH, 'O' ) ) THEN + RMACH = RMAX + END IF +* + SLAMCH = RMACH + RETURN +* +* End of SLAMCH +* + END +* +************************************************************************ +* + SUBROUTINE SLAMC1( BETA, T, RND, IEEE1 ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + LOGICAL IEEE1, RND + INTEGER BETA, T +* .. +* +* 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 .. + LOGICAL FIRST, LIEEE1, LRND + INTEGER LBETA, LT + REAL A, B, C, F, ONE, QTR, SAVEC, T1, T2 +* .. +* .. External Functions .. + REAL SLAMC3 + EXTERNAL SLAMC3 +* .. +* .. Save statement .. + SAVE FIRST, LIEEE1, LBETA, LRND, LT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + ONE = 1 +* +* 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 + C = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 10 CONTINUE + IF( C.EQ.ONE ) THEN + A = 2*A + C = SLAMC3( A, ONE ) + C = SLAMC3( C, -A ) + GO TO 10 + END IF +*+ END WHILE +* +* Now compute b = 2.0**m with the smallest positive integer m +* such that +* +* fl( a + b ) .gt. a. +* + B = 1 + C = SLAMC3( A, B ) +* +*+ WHILE( C.EQ.A )LOOP + 20 CONTINUE + IF( C.EQ.A ) THEN + B = 2*B + C = SLAMC3( A, B ) + GO TO 20 + END IF +*+ 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 + C = SLAMC3( C, -A ) + 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 = LBETA + F = SLAMC3( B / 2, -B / 100 ) + C = SLAMC3( F, A ) + IF( C.EQ.A ) THEN + LRND = .TRUE. + ELSE + LRND = .FALSE. + END IF + F = SLAMC3( B / 2, B / 100 ) + C = SLAMC3( F, A ) + IF( ( LRND ) .AND. ( C.EQ.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. +* + T1 = SLAMC3( B / 2, A ) + T2 = SLAMC3( B / 2, SAVEC ) + LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. 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 + 30 CONTINUE + IF( C.EQ.ONE ) THEN + LT = LT + 1 + A = A*LBETA + C = SLAMC3( A, ONE ) + C = SLAMC3( C, -A ) + GO TO 30 + END IF +*+ END WHILE +* + END IF +* + BETA = LBETA + T = LT + RND = LRND + IEEE1 = LIEEE1 + RETURN +* +* End of SLAMC1 +* + END +* +************************************************************************ +* + SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + LOGICAL RND + INTEGER BETA, EMAX, EMIN, T + REAL EPS, RMAX, RMIN +* .. +* +* 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 .. + LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND + INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, + $ NGNMIN, NGPMIN + REAL A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, + $ SIXTH, SMALL, THIRD, TWO, ZERO +* .. +* .. External Functions .. + REAL SLAMC3 + EXTERNAL SLAMC3 +* .. +* .. External Subroutines .. + EXTERNAL SLAMC1, SLAMC4, SLAMC5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Save statement .. + SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, + $ LRMIN, LT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / , IWARN / .FALSE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + 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 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. +* + CALL SLAMC1( LBETA, LT, LRND, LIEEE1 ) +* +* Start to find EPS. +* + B = LBETA + A = B**( -LT ) + LEPS = A +* +* Try some tricks to see whether or not this is the correct EPS. +* + B = TWO / 3 + HALF = ONE / 2 + SIXTH = SLAMC3( B, -HALF ) + THIRD = SLAMC3( SIXTH, SIXTH ) + B = SLAMC3( THIRD, -HALF ) + B = SLAMC3( B, SIXTH ) + B = ABS( B ) + IF( B.LT.LEPS ) + $ B = LEPS +* + LEPS = 1 +* +*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP + 10 CONTINUE + IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN + LEPS = B + C = SLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) + C = SLAMC3( HALF, -C ) + B = SLAMC3( HALF, C ) + C = SLAMC3( HALF, -B ) + B = SLAMC3( HALF, C ) + GO TO 10 + END IF +*+ END WHILE +* + IF( A.LT.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 + DO 20 I = 1, 3 + SMALL = SLAMC3( SMALL*RBASE, ZERO ) + 20 CONTINUE + A = SLAMC3( ONE, SMALL ) + CALL SLAMC4( NGPMIN, ONE, LBETA ) + CALL SLAMC4( NGNMIN, -ONE, LBETA ) + CALL SLAMC4( GPMIN, A, LBETA ) + CALL SLAMC4( GNMIN, -A, LBETA ) + IEEE = .FALSE. +* + IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN + IF( NGPMIN.EQ.GPMIN ) THEN + LEMIN = NGPMIN +* ( Non twos-complement machines, no gradual underflow; +* e.g., VAX ) + ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN + 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. + END IF +* + ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN + IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN + 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. + END IF +* + ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. + $ ( GPMIN.EQ.GNMIN ) ) THEN + IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN + 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. + END IF +* + ELSE + LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +*** +* Comment out this if block if EMIN is ok + IF( IWARN ) THEN + FIRST = .TRUE. + WRITE( 6, FMT = 9999 )LEMIN + END IF +*** +* +* 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 .OR. 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 + DO 30 I = 1, 1 - LEMIN + LRMIN = SLAMC3( LRMIN*RBASE, ZERO ) + 30 CONTINUE +* +* Finally, call SLAMC5 to compute EMAX and RMAX. +* + CALL SLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) + END IF +* + BETA = LBETA + T = LT + RND = LRND + EPS = LEPS + EMIN = LEMIN + RMIN = LRMIN + EMAX = LEMAX + RMAX = LRMAX +* + RETURN +* + 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', + $ ' EMIN = ', I8, / + $ ' If, after inspection, the value EMIN looks', + $ ' acceptable please comment out ', + $ / ' the IF block as marked within the code of routine', + $ ' SLAMC2,', / ' otherwise supply EMIN explicitly.', / ) +* +* End of SLAMC2 +* + END +* +************************************************************************ +* + REAL FUNCTION SLAMC3( A, B ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + REAL A, B +* .. +* +* 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, B (input) REAL +* The values A and B. +* +* ===================================================================== +* +* .. Executable Statements .. +* + SLAMC3 = A + B +* + RETURN +* +* End of SLAMC3 +* + END +* +************************************************************************ +* + SUBROUTINE SLAMC4( EMIN, START, BASE ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + INTEGER BASE, EMIN + REAL START +* .. +* +* Purpose +* ======= +* +* SLAMC4 is a service routine for SLAMC2. +* +* Arguments +* ========= +* +* EMIN (output) EMIN +* 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 .. + INTEGER I + REAL A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO +* .. +* .. External Functions .. + REAL SLAMC3 + EXTERNAL SLAMC3 +* .. +* .. Executable Statements .. +* + A = START + ONE = 1 + RBASE = ONE / BASE + ZERO = 0 + EMIN = 1 + B1 = SLAMC3( A*RBASE, 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 + 10 CONTINUE + IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. + $ ( D2.EQ.A ) ) THEN + EMIN = EMIN - 1 + A = B1 + B1 = SLAMC3( A / BASE, ZERO ) + C1 = SLAMC3( B1*BASE, ZERO ) + D1 = ZERO + DO 20 I = 1, BASE + D1 = D1 + B1 + 20 CONTINUE + B2 = SLAMC3( A*RBASE, ZERO ) + C2 = SLAMC3( B2 / RBASE, ZERO ) + D2 = ZERO + DO 30 I = 1, BASE + D2 = D2 + B2 + 30 CONTINUE + GO TO 10 + END IF +*+ END WHILE +* + RETURN +* +* End of SLAMC4 +* + END +* +************************************************************************ +* + SUBROUTINE SLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER BETA, EMAX, EMIN, P + REAL RMAX +* .. +* +* 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 .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) +* .. +* .. Local Scalars .. + INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP + REAL OLDY, RECBAS, Y, Z +* .. +* .. External Functions .. + REAL SLAMC3 + EXTERNAL SLAMC3 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. 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 + 10 CONTINUE + TRY = LEXP*2 + IF( TRY.LE.( -EMIN ) ) THEN + LEXP = TRY + EXBITS = EXBITS + 1 + GO TO 10 + END IF + IF( LEXP.EQ.-EMIN ) THEN + UEXP = LEXP + ELSE + UEXP = TRY + EXBITS = EXBITS + 1 + END IF +* +* 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 ).GT.( -LEXP-EMIN ) ) THEN + EXPSUM = 2*LEXP + ELSE + EXPSUM = 2*UEXP + END IF +* +* EXPSUM is the exponent range, approximately equal to +* EMAX - EMIN + 1 . +* + EMAX = EXPSUM + EMIN - 1 + NBITS = 1 + EXBITS + P +* +* NBITS is the total number of bits needed to store a +* floating-point number. +* + IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN +* +* 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 = EMAX - 1 + END IF +* + IF( IEEE ) THEN +* +* Assume we are on an IEEE machine which reserves one exponent +* for infinity and NaN. +* + EMAX = EMAX - 1 + END IF +* +* 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 = ONE / BETA + Z = BETA - ONE + Y = ZERO + DO 20 I = 1, P + Z = Z*RECBAS + IF( Y.LT.ONE ) + $ OLDY = Y + Y = SLAMC3( Y, Z ) + 20 CONTINUE + IF( Y.GE.ONE ) + $ Y = OLDY +* +* Now multiply by BETA**EMAX to get RMAX. +* + DO 30 I = 1, EMAX + Y = SLAMC3( Y*BETA, ZERO ) + 30 CONTINUE +* + RMAX = Y + RETURN +* +* End of SLAMC5 +* + END diff --git a/2.3-1/src/fortran/lapack/xerbla.f b/2.3-1/src/fortran/lapack/xerbla.f new file mode 100644 index 00000000..c8c9231b --- /dev/null +++ b/2.3-1/src/fortran/lapack/xerbla.f @@ -0,0 +1,45 @@ + SUBROUTINE XERBLA( SRNAME, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER*6 SRNAME + INTEGER INFO +* .. +* +* 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*6 +* 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. +* +* ===================================================================== +* +* .. Executable Statements .. +* + WRITE( *, FMT = 9999 )SRNAME, INFO +* + STOP +* + 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END diff --git a/2.3-1/src/fortran/lapack/zbdsqr.f b/2.3-1/src/fortran/lapack/zbdsqr.f new file mode 100644 index 00000000..f9086be5 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zbdsqr.f @@ -0,0 +1,742 @@ + SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, + $ LDU, C, LDC, RWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ), RWORK( * ) + COMPLEX*16 C( LDC, * ), U( LDU, * ), VT( LDVT, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION NEGONE + PARAMETER ( NEGONE = -1.0D0 ) + DOUBLE PRECISION HNDRTH + PARAMETER ( HNDRTH = 0.01D0 ) + DOUBLE PRECISION TEN + PARAMETER ( TEN = 10.0D0 ) + DOUBLE PRECISION HNDRD + PARAMETER ( HNDRD = 100.0D0 ) + DOUBLE PRECISION MEIGTH + PARAMETER ( MEIGTH = -0.125D0 ) + INTEGER MAXITR + PARAMETER ( MAXITR = 6 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, ROTATE + INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1, + $ NM12, NM13, OLDLL, OLDM + DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, + $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, + $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA, + $ SN, THRESH, TOL, TOLMUL, UNFL +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLARTG, DLAS2, DLASQ1, DLASV2, XERBLA, ZDROT, + $ ZDSCAL, ZLASR, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NCVT.LT.0 ) THEN + INFO = -3 + ELSE IF( NRU.LT.0 ) THEN + INFO = -4 + ELSE IF( NCC.LT.0 ) THEN + INFO = -5 + ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. + $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN + INFO = -9 + ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN + INFO = -11 + ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. + $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZBDSQR', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN + IF( N.EQ.1 ) + $ GO TO 160 +* +* ROTATE is true if any singular vectors desired, false otherwise +* + ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) +* +* If no singular vectors desired, use qd algorithm +* + IF( .NOT.ROTATE ) THEN + CALL DLASQ1( N, D, E, RWORK, INFO ) + RETURN + END IF +* + 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 ) THEN + DO 10 I = 1, N - 1 + CALL 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 + 10 CONTINUE +* +* Update singular vectors if desired +* + IF( NRU.GT.0 ) + $ CALL ZLASR( 'R', 'V', 'F', NRU, N, RWORK( 1 ), RWORK( N ), + $ U, LDU ) + IF( NCC.GT.0 ) + $ CALL ZLASR( 'L', 'V', 'F', N, NCC, RWORK( 1 ), RWORK( N ), + $ C, LDC ) + END IF +* +* 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)) +* + TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) ) + TOL = TOLMUL*EPS +* +* Compute approximate maximum, minimum singular values +* + SMAX = ZERO + DO 20 I = 1, N + SMAX = MAX( SMAX, ABS( D( I ) ) ) + 20 CONTINUE + DO 30 I = 1, N - 1 + SMAX = MAX( SMAX, ABS( E( I ) ) ) + 30 CONTINUE + SMINL = ZERO + IF( TOL.GE.ZERO ) THEN +* +* Relative accuracy desired +* + SMINOA = ABS( D( 1 ) ) + IF( SMINOA.EQ.ZERO ) + $ GO TO 50 + MU = SMINOA + DO 40 I = 2, N + MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) ) + SMINOA = MIN( SMINOA, MU ) + IF( SMINOA.EQ.ZERO ) + $ GO TO 50 + 40 CONTINUE + 50 CONTINUE + SMINOA = SMINOA / SQRT( DBLE( N ) ) + THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL ) + ELSE +* +* Absolute accuracy desired +* + THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL ) + END IF +* +* 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 = MAXITR*N*N + ITER = 0 + OLDLL = -1 + OLDM = -1 +* +* M points to last element of unconverged part of matrix +* + M = N +* +* Begin main iteration loop +* + 60 CONTINUE +* +* Check for convergence or exceeding iteration count +* + IF( M.LE.1 ) + $ GO TO 160 + IF( ITER.GT.MAXIT ) + $ GO TO 200 +* +* Find diagonal block of matrix to work on +* + IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH ) + $ D( M ) = ZERO + SMAX = ABS( D( M ) ) + SMIN = SMAX + DO 70 LLL = 1, M - 1 + LL = M - LLL + ABSS = ABS( D( LL ) ) + ABSE = ABS( E( LL ) ) + IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH ) + $ D( LL ) = ZERO + IF( ABSE.LE.THRESH ) + $ GO TO 80 + SMIN = MIN( SMIN, ABSS ) + SMAX = MAX( SMAX, ABSS, ABSE ) + 70 CONTINUE + LL = 0 + GO TO 90 + 80 CONTINUE + E( LL ) = ZERO +* +* Matrix splits since E(LL) = 0 +* + IF( LL.EQ.M-1 ) THEN +* +* Convergence of bottom singular value, return to top of loop +* + M = M - 1 + GO TO 60 + END IF + 90 CONTINUE + LL = LL + 1 +* +* E(LL) through E(M-1) are nonzero, E(LL-1) is zero +* + IF( LL.EQ.M-1 ) THEN +* +* 2 by 2 block, handle separately +* + CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR, + $ COSR, SINL, COSL ) + D( M-1 ) = SIGMX + E( M-1 ) = ZERO + D( M ) = SIGMN +* +* Compute singular vectors, if desired +* + IF( NCVT.GT.0 ) + $ CALL ZDROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, + $ COSR, SINR ) + IF( NRU.GT.0 ) + $ CALL ZDROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL ) + IF( NCC.GT.0 ) + $ CALL ZDROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL, + $ SINL ) + M = M - 2 + GO TO 60 + END IF +* +* If working on new submatrix, choose shift direction +* (from larger end diagonal element towards smaller) +* + IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN + IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN +* +* 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 + END IF + END IF +* +* Apply convergence tests +* + IF( IDIR.EQ.1 ) THEN +* +* Run convergence test in forward direction +* First apply standard test to bottom of matrix +* + IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR. + $ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN + E( M-1 ) = ZERO + GO TO 60 + END IF +* + IF( TOL.GE.ZERO ) THEN +* +* If relative accuracy desired, +* apply convergence criterion forward +* + MU = ABS( D( LL ) ) + SMINL = MU + DO 100 LLL = LL, M - 1 + IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN + E( LLL ) = ZERO + GO TO 60 + END IF + MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) + SMINL = MIN( SMINL, MU ) + 100 CONTINUE + END IF +* + ELSE +* +* Run convergence test in backward direction +* First apply standard test to top of matrix +* + IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR. + $ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN + E( LL ) = ZERO + GO TO 60 + END IF +* + IF( TOL.GE.ZERO ) THEN +* +* If relative accuracy desired, +* apply convergence criterion backward +* + MU = ABS( D( M ) ) + SMINL = MU + DO 110 LLL = M - 1, LL, -1 + IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN + E( LLL ) = ZERO + GO TO 60 + END IF + MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) + SMINL = MIN( SMINL, MU ) + 110 CONTINUE + END IF + END IF + OLDLL = LL + OLDM = M +* +* Compute shift. First, test if shifting would ruin relative +* accuracy, and if so set the shift to zero. +* + IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE. + $ MAX( EPS, HNDRTH*TOL ) ) THEN +* +* Use a zero shift to avoid loss of relative accuracy +* + SHIFT = ZERO + ELSE +* +* Compute the shift from 2-by-2 block at end of matrix +* + IF( IDIR.EQ.1 ) THEN + SLL = ABS( D( LL ) ) + CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R ) + ELSE + SLL = ABS( D( M ) ) + CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R ) + END IF +* +* Test if shift negligible, and if so set to zero +* + IF( SLL.GT.ZERO ) THEN + IF( ( SHIFT / SLL )**2.LT.EPS ) + $ SHIFT = ZERO + END IF + END IF +* +* Increment iteration count +* + ITER = ITER + M - LL +* +* If SHIFT = 0, do simplified QR iteration +* + IF( SHIFT.EQ.ZERO ) THEN + IF( IDIR.EQ.1 ) THEN +* +* Chase bulge from top to bottom +* Save cosines and sines for later singular vector updates +* + CS = ONE + OLDCS = ONE + DO 120 I = LL, M - 1 + CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) + IF( I.GT.LL ) + $ E( I-1 ) = OLDSN*R + CALL DLARTG( OLDCS*R, D( I+1 )*SN, 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 + 120 CONTINUE + H = D( M )*CS + D( M ) = H*OLDCS + E( M-1 ) = H*OLDSN +* +* Update singular vectors +* + IF( NCVT.GT.0 ) + $ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ), + $ RWORK( N ), VT( LL, 1 ), LDVT ) + IF( NRU.GT.0 ) + $ CALL ZLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ), + $ RWORK( NM13+1 ), U( 1, LL ), LDU ) + IF( NCC.GT.0 ) + $ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCC, RWORK( NM12+1 ), + $ RWORK( NM13+1 ), C( LL, 1 ), LDC ) +* +* Test convergence +* + IF( ABS( E( M-1 ) ).LE.THRESH ) + $ E( M-1 ) = ZERO +* + ELSE +* +* Chase bulge from bottom to top +* Save cosines and sines for later singular vector updates +* + CS = ONE + OLDCS = ONE + DO 130 I = M, LL + 1, -1 + CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) + IF( I.LT.M ) + $ E( I ) = OLDSN*R + CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) + RWORK( I-LL ) = CS + RWORK( I-LL+NM1 ) = -SN + RWORK( I-LL+NM12 ) = OLDCS + RWORK( I-LL+NM13 ) = -OLDSN + 130 CONTINUE + H = D( LL )*CS + D( LL ) = H*OLDCS + E( LL ) = H*OLDSN +* +* Update singular vectors +* + IF( NCVT.GT.0 ) + $ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ), + $ RWORK( NM13+1 ), VT( LL, 1 ), LDVT ) + IF( NRU.GT.0 ) + $ CALL ZLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ), + $ RWORK( N ), U( 1, LL ), LDU ) + IF( NCC.GT.0 ) + $ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCC, RWORK( 1 ), + $ RWORK( N ), C( LL, 1 ), LDC ) +* +* Test convergence +* + IF( ABS( E( LL ) ).LE.THRESH ) + $ E( LL ) = ZERO + END IF + ELSE +* +* Use nonzero shift +* + IF( IDIR.EQ.1 ) THEN +* +* Chase bulge from top to bottom +* Save cosines and sines for later singular vector updates +* + F = ( ABS( D( LL ) )-SHIFT )* + $ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) ) + G = E( LL ) + DO 140 I = LL, M - 1 + CALL DLARTG( F, G, COSR, SINR, R ) + IF( I.GT.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 ) + CALL 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.LT.M-1 ) THEN + G = SINL*E( I+1 ) + E( I+1 ) = COSL*E( I+1 ) + END IF + RWORK( I-LL+1 ) = COSR + RWORK( I-LL+1+NM1 ) = SINR + RWORK( I-LL+1+NM12 ) = COSL + RWORK( I-LL+1+NM13 ) = SINL + 140 CONTINUE + E( M-1 ) = F +* +* Update singular vectors +* + IF( NCVT.GT.0 ) + $ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ), + $ RWORK( N ), VT( LL, 1 ), LDVT ) + IF( NRU.GT.0 ) + $ CALL ZLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ), + $ RWORK( NM13+1 ), U( 1, LL ), LDU ) + IF( NCC.GT.0 ) + $ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCC, RWORK( NM12+1 ), + $ RWORK( NM13+1 ), C( LL, 1 ), LDC ) +* +* Test convergence +* + IF( ABS( E( M-1 ) ).LE.THRESH ) + $ E( M-1 ) = ZERO +* + ELSE +* +* Chase bulge from bottom to top +* Save cosines and sines for later singular vector updates +* + F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT / + $ D( M ) ) + G = E( M-1 ) + DO 150 I = M, LL + 1, -1 + CALL DLARTG( F, G, COSR, SINR, R ) + IF( I.LT.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 ) + CALL 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.GT.LL+1 ) THEN + G = SINL*E( I-2 ) + E( I-2 ) = COSL*E( I-2 ) + END IF + RWORK( I-LL ) = COSR + RWORK( I-LL+NM1 ) = -SINR + RWORK( I-LL+NM12 ) = COSL + RWORK( I-LL+NM13 ) = -SINL + 150 CONTINUE + E( LL ) = F +* +* Test convergence +* + IF( ABS( E( LL ) ).LE.THRESH ) + $ E( LL ) = ZERO +* +* Update singular vectors if desired +* + IF( NCVT.GT.0 ) + $ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ), + $ RWORK( NM13+1 ), VT( LL, 1 ), LDVT ) + IF( NRU.GT.0 ) + $ CALL ZLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ), + $ RWORK( N ), U( 1, LL ), LDU ) + IF( NCC.GT.0 ) + $ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCC, RWORK( 1 ), + $ RWORK( N ), C( LL, 1 ), LDC ) + END IF + END IF +* +* QR iteration finished, go back and check convergence +* + GO TO 60 +* +* All singular values converged, so make them positive +* + 160 CONTINUE + DO 170 I = 1, N + IF( D( I ).LT.ZERO ) THEN + D( I ) = -D( I ) +* +* Change sign of singular vectors, if desired +* + IF( NCVT.GT.0 ) + $ CALL ZDSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT ) + END IF + 170 CONTINUE +* +* Sort the singular values into decreasing order (insertion sort on +* singular values, but only one transposition per singular vector) +* + DO 190 I = 1, N - 1 +* +* Scan for smallest D(I) +* + ISUB = 1 + SMIN = D( 1 ) + DO 180 J = 2, N + 1 - I + IF( D( J ).LE.SMIN ) THEN + ISUB = J + SMIN = D( J ) + END IF + 180 CONTINUE + IF( ISUB.NE.N+1-I ) THEN +* +* Swap singular values and vectors +* + D( ISUB ) = D( N+1-I ) + D( N+1-I ) = SMIN + IF( NCVT.GT.0 ) + $ CALL ZSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ), + $ LDVT ) + IF( NRU.GT.0 ) + $ CALL ZSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 ) + IF( NCC.GT.0 ) + $ CALL ZSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC ) + END IF + 190 CONTINUE + GO TO 220 +* +* Maximum number of iterations exceeded, failure to converge +* + 200 CONTINUE + INFO = 0 + DO 210 I = 1, N - 1 + IF( E( I ).NE.ZERO ) + $ INFO = INFO + 1 + 210 CONTINUE + 220 CONTINUE + RETURN +* +* End of ZBDSQR +* + END diff --git a/2.3-1/src/fortran/lapack/zdrot.f b/2.3-1/src/fortran/lapack/zdrot.f new file mode 100644 index 00000000..3b946e99 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zdrot.f @@ -0,0 +1,96 @@ + SUBROUTINE ZDROT( N, CX, INCX, CY, INCY, C, S ) +* +* .. Scalar Arguments .. + INTEGER INCX, INCY, N + DOUBLE PRECISION C, S +* .. +* .. Array Arguments .. + COMPLEX*16 CX( * ), CY( * ) +* .. +* +* 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 .. + INTEGER I, IX, IY + COMPLEX*16 CTEMP +* .. +* .. Executable Statements .. +* + IF( N.LE.0 ) + $ RETURN + IF( INCX.EQ.1 .AND. INCY.EQ.1 ) + $ GO TO 20 +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF( INCX.LT.0 ) + $ IX = ( -N+1 )*INCX + 1 + IF( INCY.LT.0 ) + $ IY = ( -N+1 )*INCY + 1 + DO 10 I = 1, N + CTEMP = C*CX( IX ) + S*CY( IY ) + CY( IY ) = C*CY( IY ) - S*CX( IX ) + CX( IX ) = CTEMP + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +* +* code for both increments equal to 1 +* + 20 CONTINUE + DO 30 I = 1, N + CTEMP = C*CX( I ) + S*CY( I ) + CY( I ) = C*CY( I ) - S*CX( I ) + CX( I ) = CTEMP + 30 CONTINUE + RETURN + END diff --git a/2.3-1/src/fortran/lapack/zdrscl.f b/2.3-1/src/fortran/lapack/zdrscl.f new file mode 100644 index 00000000..11686d0b --- /dev/null +++ b/2.3-1/src/fortran/lapack/zdrscl.f @@ -0,0 +1,114 @@ + SUBROUTINE ZDRSCL( N, SA, SX, INCX ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION SA +* .. +* .. Array Arguments .. + COMPLEX*16 SX( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + DOUBLE PRECISION BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, ZDSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Get machine parameters +* + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* +* Initialize the denominator to SA and the numerator to 1. +* + CDEN = SA + CNUM = ONE +* + 10 CONTINUE + CDEN1 = CDEN*SMLNUM + CNUM1 = CNUM / BIGNUM + IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN +* +* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. +* + MUL = SMLNUM + DONE = .FALSE. + CDEN = CDEN1 + ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN +* +* 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. + END IF +* +* Scale the vector X by MUL +* + CALL ZDSCAL( N, MUL, SX, INCX ) +* + IF( .NOT.DONE ) + $ GO TO 10 +* + RETURN +* +* End of ZDRSCL +* + END diff --git a/2.3-1/src/fortran/lapack/zgebak.f b/2.3-1/src/fortran/lapack/zgebak.f new file mode 100644 index 00000000..1023601d --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgebak.f @@ -0,0 +1,189 @@ + SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, + $ INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOB, SIDE + INTEGER IHI, ILO, INFO, LDV, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION SCALE( * ) + COMPLEX*16 V( LDV, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFTV, RIGHTV + INTEGER I, II, K + DOUBLE PRECISION S +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZDSCAL, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Decode and Test the input parameters +* + RIGHTV = LSAME( SIDE, 'R' ) + LEFTV = LSAME( SIDE, 'L' ) +* + INFO = 0 + IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. + $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN + INFO = -1 + ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -7 + ELSE IF( LDV.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEBAK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + IF( M.EQ.0 ) + $ RETURN + IF( LSAME( JOB, 'N' ) ) + $ RETURN +* + IF( ILO.EQ.IHI ) + $ GO TO 30 +* +* Backward balance +* + IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN +* + IF( RIGHTV ) THEN + DO 10 I = ILO, IHI + S = SCALE( I ) + CALL ZDSCAL( M, S, V( I, 1 ), LDV ) + 10 CONTINUE + END IF +* + IF( LEFTV ) THEN + DO 20 I = ILO, IHI + S = ONE / SCALE( I ) + CALL ZDSCAL( M, S, V( I, 1 ), LDV ) + 20 CONTINUE + END IF +* + END IF +* +* Backward permutation +* +* For I = ILO-1 step -1 until 1, +* IHI+1 step 1 until N do -- +* + 30 CONTINUE + IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN + IF( RIGHTV ) THEN + DO 40 II = 1, N + I = II + IF( I.GE.ILO .AND. I.LE.IHI ) + $ GO TO 40 + IF( I.LT.ILO ) + $ I = ILO - II + K = SCALE( I ) + IF( K.EQ.I ) + $ GO TO 40 + CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 40 CONTINUE + END IF +* + IF( LEFTV ) THEN + DO 50 II = 1, N + I = II + IF( I.GE.ILO .AND. I.LE.IHI ) + $ GO TO 50 + IF( I.LT.ILO ) + $ I = ILO - II + K = SCALE( I ) + IF( K.EQ.I ) + $ GO TO 50 + CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 50 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEBAK +* + END diff --git a/2.3-1/src/fortran/lapack/zgebal.f b/2.3-1/src/fortran/lapack/zgebal.f new file mode 100644 index 00000000..67ac2e14 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgebal.f @@ -0,0 +1,330 @@ + SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOB + INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION SCALE( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION SCLFAC + PARAMETER ( SCLFAC = 2.0D+0 ) + DOUBLE PRECISION FACTOR + PARAMETER ( FACTOR = 0.95D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOCONV + INTEGER I, ICA, IEXC, IRA, J, K, L, M + DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, + $ SFMIN2 + COMPLEX*16 CDUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IZAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZDSCAL, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. + $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEBAL', -INFO ) + RETURN + END IF +* + K = 1 + L = N +* + IF( N.EQ.0 ) + $ GO TO 210 +* + IF( LSAME( JOB, 'N' ) ) THEN + DO 10 I = 1, N + SCALE( I ) = ONE + 10 CONTINUE + GO TO 210 + END IF +* + IF( LSAME( JOB, 'S' ) ) + $ GO TO 120 +* +* Permutation to isolate eigenvalues if possible +* + GO TO 50 +* +* Row and column exchange. +* + 20 CONTINUE + SCALE( M ) = J + IF( J.EQ.M ) + $ GO TO 30 +* + CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) + CALL ZSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA ) +* + 30 CONTINUE + GO TO ( 40, 80 )IEXC +* +* Search for rows isolating an eigenvalue and push them down. +* + 40 CONTINUE + IF( L.EQ.1 ) + $ GO TO 210 + L = L - 1 +* + 50 CONTINUE + DO 70 J = L, 1, -1 +* + DO 60 I = 1, L + IF( I.EQ.J ) + $ GO TO 60 + IF( DBLE( A( J, I ) ).NE.ZERO .OR. DIMAG( A( J, I ) ).NE. + $ ZERO )GO TO 70 + 60 CONTINUE +* + M = L + IEXC = 1 + GO TO 20 + 70 CONTINUE +* + GO TO 90 +* +* Search for columns isolating an eigenvalue and push them left. +* + 80 CONTINUE + K = K + 1 +* + 90 CONTINUE + DO 110 J = K, L +* + DO 100 I = K, L + IF( I.EQ.J ) + $ GO TO 100 + IF( DBLE( A( I, J ) ).NE.ZERO .OR. DIMAG( A( I, J ) ).NE. + $ ZERO )GO TO 110 + 100 CONTINUE +* + M = K + IEXC = 2 + GO TO 20 + 110 CONTINUE +* + 120 CONTINUE + DO 130 I = K, L + SCALE( I ) = ONE + 130 CONTINUE +* + IF( LSAME( JOB, 'P' ) ) + $ GO TO 210 +* +* Balance the submatrix in rows K to L. +* +* Iterative loop for norm reduction +* + SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) + SFMAX1 = ONE / SFMIN1 + SFMIN2 = SFMIN1*SCLFAC + SFMAX2 = ONE / SFMIN2 + 140 CONTINUE + NOCONV = .FALSE. +* + DO 200 I = K, L + C = ZERO + R = ZERO +* + DO 150 J = K, L + IF( J.EQ.I ) + $ GO TO 150 + C = C + CABS1( A( J, I ) ) + R = R + CABS1( A( I, J ) ) + 150 CONTINUE + ICA = IZAMAX( L, A( 1, I ), 1 ) + CA = ABS( A( ICA, I ) ) + IRA = IZAMAX( N-K+1, A( I, K ), LDA ) + RA = ABS( A( I, IRA+K-1 ) ) +* +* Guard against zero C or R due to underflow. +* + IF( C.EQ.ZERO .OR. R.EQ.ZERO ) + $ GO TO 200 + G = R / SCLFAC + F = ONE + S = C + R + 160 CONTINUE + IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. + $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170 + F = F*SCLFAC + C = C*SCLFAC + CA = CA*SCLFAC + R = R / SCLFAC + G = G / SCLFAC + RA = RA / SCLFAC + GO TO 160 +* + 170 CONTINUE + G = C / SCLFAC + 180 CONTINUE + IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. + $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190 + F = F / SCLFAC + C = C / SCLFAC + G = G / SCLFAC + CA = CA / SCLFAC + R = R*SCLFAC + RA = RA*SCLFAC + GO TO 180 +* +* Now balance. +* + 190 CONTINUE + IF( ( C+R ).GE.FACTOR*S ) + $ GO TO 200 + IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN + IF( F*SCALE( I ).LE.SFMIN1 ) + $ GO TO 200 + END IF + IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN + IF( SCALE( I ).GE.SFMAX1 / F ) + $ GO TO 200 + END IF + G = ONE / F + SCALE( I ) = SCALE( I )*F + NOCONV = .TRUE. +* + CALL ZDSCAL( N-K+1, G, A( I, K ), LDA ) + CALL ZDSCAL( L, F, A( 1, I ), 1 ) +* + 200 CONTINUE +* + IF( NOCONV ) + $ GO TO 140 +* + 210 CONTINUE + ILO = K + IHI = L +* + RETURN +* +* End of ZGEBAL +* + END diff --git a/2.3-1/src/fortran/lapack/zgebd2.f b/2.3-1/src/fortran/lapack/zgebd2.f new file mode 100644 index 00000000..5ba52e87 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgebd2.f @@ -0,0 +1,250 @@ + SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) + COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I + COMPLEX*16 ALPHA +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.LT.0 ) THEN + CALL XERBLA( 'ZGEBD2', -INFO ) + RETURN + END IF +* + IF( M.GE.N ) THEN +* +* Reduce to upper bidiagonal form +* + DO 10 I = 1, N +* +* Generate elementary reflector H(i) to annihilate A(i+1:m,i) +* + ALPHA = A( I, I ) + CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1, + $ TAUQ( I ) ) + D( I ) = ALPHA + A( I, I ) = ONE +* +* Apply H(i)' to A(i:m,i+1:n) from the left +* + IF( I.LT.N ) + $ CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, + $ DCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK ) + A( I, I ) = D( I ) +* + IF( I.LT.N ) THEN +* +* Generate elementary reflector G(i) to annihilate +* A(i,i+2:n) +* + CALL ZLACGV( N-I, A( I, I+1 ), LDA ) + ALPHA = A( I, I+1 ) + CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA, + $ TAUP( I ) ) + E( I ) = ALPHA + A( I, I+1 ) = ONE +* +* Apply G(i) to A(i+1:m,i+1:n) from the right +* + CALL ZLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, + $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) + CALL ZLACGV( N-I, A( I, I+1 ), LDA ) + A( I, I+1 ) = E( I ) + ELSE + TAUP( I ) = ZERO + END IF + 10 CONTINUE + ELSE +* +* Reduce to lower bidiagonal form +* + DO 20 I = 1, M +* +* Generate elementary reflector G(i) to annihilate A(i,i+1:n) +* + CALL ZLACGV( N-I+1, A( I, I ), LDA ) + ALPHA = A( I, I ) + CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, + $ TAUP( I ) ) + D( I ) = ALPHA + A( I, I ) = ONE +* +* Apply G(i) to A(i+1:m,i:n) from the right +* + IF( I.LT.M ) + $ CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAUP( I ), A( I+1, I ), LDA, WORK ) + CALL ZLACGV( N-I+1, A( I, I ), LDA ) + A( I, I ) = D( I ) +* + IF( I.LT.M ) THEN +* +* Generate elementary reflector H(i) to annihilate +* A(i+2:m,i) +* + ALPHA = A( I+1, I ) + CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1, + $ TAUQ( I ) ) + E( I ) = ALPHA + A( I+1, I ) = ONE +* +* Apply H(i)' to A(i+1:m,i+1:n) from the left +* + CALL ZLARF( 'Left', M-I, N-I, A( I+1, I ), 1, + $ DCONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA, + $ WORK ) + A( I+1, I ) = E( I ) + ELSE + TAUQ( I ) = ZERO + END IF + 20 CONTINUE + END IF + RETURN +* +* End of ZGEBD2 +* + END diff --git a/2.3-1/src/fortran/lapack/zgebrd.f b/2.3-1/src/fortran/lapack/zgebrd.f new file mode 100644 index 00000000..4f97bd7e --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgebrd.f @@ -0,0 +1,268 @@ + SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, + $ INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) + COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, + $ NBMIN, NX + DOUBLE PRECISION WS +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGEBD2, ZGEMM, ZLABRD +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + NB = MAX( 1, ILAENV( 1, 'ZGEBRD', ' ', M, N, -1, -1 ) ) + LWKOPT = ( M+N )*NB + WORK( 1 ) = DBLE( LWKOPT ) + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + IF( INFO.LT.0 ) THEN + CALL XERBLA( 'ZGEBRD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + WS = MAX( M, N ) + LDWRKX = M + LDWRKY = N +* + IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN +* +* Set the crossover point NX. +* + NX = MAX( NB, ILAENV( 3, 'ZGEBRD', ' ', M, N, -1, -1 ) ) +* +* Determine when to switch from blocked to unblocked code. +* + IF( NX.LT.MINMN ) THEN + WS = ( M+N )*NB + IF( LWORK.LT.WS ) THEN +* +* Not enough work space for the optimal NB, consider using +* a smaller block size. +* + NBMIN = ILAENV( 2, 'ZGEBRD', ' ', M, N, -1, -1 ) + IF( LWORK.GE.( M+N )*NBMIN ) THEN + NB = LWORK / ( M+N ) + ELSE + NB = 1 + NX = MINMN + END IF + END IF + END IF + ELSE + NX = MINMN + END IF +* + DO 30 I = 1, MINMN - NX, NB +* +* 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 +* + CALL ZLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ), + $ TAUQ( I ), TAUP( I ), WORK, 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' +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-I-NB+1, + $ N-I-NB+1, NB, -ONE, A( I+NB, I ), LDA, + $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE, + $ A( I+NB, I+NB ), LDA ) + CALL ZGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, + $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, + $ ONE, A( I+NB, I+NB ), LDA ) +* +* Copy diagonal and off-diagonal elements of B back into A +* + IF( M.GE.N ) THEN + DO 10 J = I, I + NB - 1 + A( J, J ) = D( J ) + A( J, J+1 ) = E( J ) + 10 CONTINUE + ELSE + DO 20 J = I, I + NB - 1 + A( J, J ) = D( J ) + A( J+1, J ) = E( J ) + 20 CONTINUE + END IF + 30 CONTINUE +* +* Use unblocked code to reduce the remainder of the matrix +* + CALL ZGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ), + $ TAUQ( I ), TAUP( I ), WORK, IINFO ) + WORK( 1 ) = WS + RETURN +* +* End of ZGEBRD +* + END diff --git a/2.3-1/src/fortran/lapack/zgecon.f b/2.3-1/src/fortran/lapack/zgecon.f new file mode 100644 index 00000000..cfaaca35 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgecon.f @@ -0,0 +1,193 @@ + SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, + $ INFO ) +* +* -- LAPACK routine (version 3.1) -- +* 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 .. + CHARACTER NORM + INTEGER INFO, LDA, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ONENRM + CHARACTER NORMIN + INTEGER IX, KASE, KASE1 + DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU + COMPLEX*16 ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IZAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZDRSCL, ZLACN2, ZLATRS +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG, MAX +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) + IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGECON', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.EQ.ZERO ) THEN + RETURN + END IF +* + SMLNUM = DLAMCH( 'Safe minimum' ) +* +* Estimate the norm of inv(A). +* + AINVNM = ZERO + NORMIN = 'N' + IF( ONENRM ) THEN + KASE1 = 1 + ELSE + KASE1 = 2 + END IF + KASE = 0 + 10 CONTINUE + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.KASE1 ) THEN +* +* Multiply by inv(L). +* + CALL ZLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A, + $ LDA, WORK, SL, RWORK, INFO ) +* +* Multiply by inv(U). +* + CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, + $ A, LDA, WORK, SU, RWORK( N+1 ), INFO ) + ELSE +* +* Multiply by inv(U'). +* + CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit', + $ NORMIN, N, A, LDA, WORK, SU, RWORK( N+1 ), + $ INFO ) +* +* Multiply by inv(L'). +* + CALL ZLATRS( 'Lower', 'Conjugate transpose', 'Unit', NORMIN, + $ N, A, LDA, WORK, SL, RWORK, INFO ) + END IF +* +* Divide X by 1/(SL*SU) if doing so will not cause overflow. +* + SCALE = SL*SU + NORMIN = 'Y' + IF( SCALE.NE.ONE ) THEN + IX = IZAMAX( N, WORK, 1 ) + IF( SCALE.LT.CABS1( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) + $ GO TO 20 + CALL ZDRSCL( N, SCALE, WORK, 1 ) + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + 20 CONTINUE + RETURN +* +* End of ZGECON +* + END diff --git a/2.3-1/src/fortran/lapack/zgees.f b/2.3-1/src/fortran/lapack/zgees.f new file mode 100644 index 00000000..ade5f9f2 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgees.f @@ -0,0 +1,324 @@ + SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, + $ LDVS, WORK, LWORK, RWORK, BWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBVS, SORT + INTEGER INFO, LDA, LDVS, LWORK, N, SDIM +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * ) +* .. +* .. Function Arguments .. + LOGICAL SELECT + EXTERNAL SELECT +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, SCALEA, WANTST, WANTVS + INTEGER HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO, + $ ITAU, IWRK, MAXWRK, MINWRK + DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM +* .. +* .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, XERBLA, ZCOPY, ZGEBAK, ZGEBAL, ZGEHRD, + $ ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + WANTVS = LSAME( JOBVS, 'V' ) + WANTST = LSAME( SORT, 'S' ) + IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN + INFO = -10 + END IF +* +* 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.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + ELSE + MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) + MINWRK = 2*N +* + CALL ZHSEQR( 'S', JOBVS, N, 1, N, A, LDA, W, VS, LDVS, + $ WORK, -1, IEVAL ) + HSWORK = WORK( 1 ) +* + IF( .NOT.WANTVS ) THEN + MAXWRK = MAX( MAXWRK, HSWORK ) + ELSE + MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', + $ ' ', N, 1, N, -1 ) ) + MAXWRK = MAX( MAXWRK, HSWORK ) + END IF + END IF + WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEES ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + SDIM = 0 + RETURN + END IF +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = ZLANGE( 'M', N, N, A, LDA, DUM ) + SCALEA = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + SCALEA = .TRUE. + CSCALE = SMLNUM + ELSE IF( ANRM.GT.BIGNUM ) THEN + SCALEA = .TRUE. + CSCALE = BIGNUM + END IF + IF( SCALEA ) + $ CALL ZLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) +* +* Permute the matrix to make it more nearly triangular +* (CWorkspace: none) +* (RWorkspace: need N) +* + IBAL = 1 + CALL ZGEBAL( 'P', N, A, 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 + CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* + IF( WANTVS ) THEN +* +* Copy Householder vectors to VS +* + CALL ZLACPY( 'L', N, N, A, LDA, VS, LDVS ) +* +* Generate unitary matrix in VS +* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) +* (RWorkspace: none) +* + CALL ZUNGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) + END IF +* + SDIM = 0 +* +* Perform QR iteration, accumulating Schur vectors in VS if desired +* (CWorkspace: need 1, prefer HSWORK (see comments) ) +* (RWorkspace: none) +* + IWRK = ITAU + CALL ZHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, W, VS, LDVS, + $ WORK( IWRK ), LWORK-IWRK+1, IEVAL ) + IF( IEVAL.GT.0 ) + $ INFO = IEVAL +* +* Sort eigenvalues if desired +* + IF( WANTST .AND. INFO.EQ.0 ) THEN + IF( SCALEA ) + $ CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, W, N, IERR ) + DO 10 I = 1, N + BWORK( I ) = SELECT( W( I ) ) + 10 CONTINUE +* +* Reorder eigenvalues and transform Schur vectors +* (CWorkspace: none) +* (RWorkspace: none) +* + CALL ZTRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, W, SDIM, + $ S, SEP, WORK( IWRK ), LWORK-IWRK+1, ICOND ) + END IF +* + IF( WANTVS ) THEN +* +* Undo balancing +* (CWorkspace: none) +* (RWorkspace: need N) +* + CALL ZGEBAK( 'P', 'R', N, ILO, IHI, RWORK( IBAL ), N, VS, LDVS, + $ IERR ) + END IF +* + IF( SCALEA ) THEN +* +* Undo scaling for the Schur form of A +* + CALL ZLASCL( 'U', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR ) + CALL ZCOPY( N, A, LDA+1, W, 1 ) + END IF +* + WORK( 1 ) = MAXWRK + RETURN +* +* End of ZGEES +* + END diff --git a/2.3-1/src/fortran/lapack/zgeev.f b/2.3-1/src/fortran/lapack/zgeev.f new file mode 100644 index 00000000..0fa66307 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgeev.f @@ -0,0 +1,396 @@ + SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, + $ WORK, LWORK, RWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBVL, JOBVR + INTEGER INFO, LDA, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), + $ W( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, SCALEA, WANTVL, WANTVR + CHARACTER SIDE + INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU, + $ IWRK, K, MAXWRK, MINWRK, NOUT + DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM + COMPLEX*16 TMP +* .. +* .. Local Arrays .. + LOGICAL SELECT( 1 ) + DOUBLE PRECISION DUM( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD, + $ ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC, ZUNGHR +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DZNRM2, ZLANGE + EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DZNRM2, ZLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + WANTVL = LSAME( JOBVL, 'V' ) + WANTVR = LSAME( JOBVR, 'V' ) + IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN + INFO = -10 + END IF +* +* 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.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + ELSE + MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) + MINWRK = 2*N + IF( WANTVL ) THEN + MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', + $ ' ', N, 1, N, -1 ) ) + CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL, + $ WORK, -1, INFO ) + ELSE IF( WANTVR ) THEN + MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', + $ ' ', N, 1, N, -1 ) ) + CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR, + $ WORK, -1, INFO ) + ELSE + CALL ZHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR, LDVR, + $ WORK, -1, INFO ) + END IF + HSWORK = WORK( 1 ) + MAXWRK = MAX( MAXWRK, HSWORK, MINWRK ) + END IF + WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEEV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = ZLANGE( 'M', N, N, A, LDA, DUM ) + SCALEA = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + SCALEA = .TRUE. + CSCALE = SMLNUM + ELSE IF( ANRM.GT.BIGNUM ) THEN + SCALEA = .TRUE. + CSCALE = BIGNUM + END IF + IF( SCALEA ) + $ CALL ZLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) +* +* Balance the matrix +* (CWorkspace: none) +* (RWorkspace: need N) +* + IBAL = 1 + CALL ZGEBAL( 'B', N, A, 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 + CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* + IF( WANTVL ) THEN +* +* Want left eigenvectors +* Copy Householder vectors to VL +* + SIDE = 'L' + CALL ZLACPY( 'L', N, N, A, LDA, VL, LDVL ) +* +* Generate unitary matrix in VL +* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) +* (RWorkspace: none) +* + CALL ZUNGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* +* Perform QR iteration, accumulating Schur vectors in VL +* (CWorkspace: need 1, prefer HSWORK (see comments) ) +* (RWorkspace: none) +* + IWRK = ITAU + CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VL, LDVL, + $ WORK( IWRK ), LWORK-IWRK+1, INFO ) +* + IF( WANTVR ) THEN +* +* Want left and right eigenvectors +* Copy Schur vectors to VR +* + SIDE = 'B' + CALL ZLACPY( 'F', N, N, VL, LDVL, VR, LDVR ) + END IF +* + ELSE IF( WANTVR ) THEN +* +* Want right eigenvectors +* Copy Householder vectors to VR +* + SIDE = 'R' + CALL ZLACPY( 'L', N, N, A, LDA, VR, LDVR ) +* +* Generate unitary matrix in VR +* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) +* (RWorkspace: none) +* + CALL ZUNGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* +* Perform QR iteration, accumulating Schur vectors in VR +* (CWorkspace: need 1, prefer HSWORK (see comments) ) +* (RWorkspace: none) +* + IWRK = ITAU + CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VR, LDVR, + $ WORK( IWRK ), LWORK-IWRK+1, INFO ) +* + ELSE +* +* Compute eigenvalues only +* (CWorkspace: need 1, prefer HSWORK (see comments) ) +* (RWorkspace: none) +* + IWRK = ITAU + CALL ZHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, W, VR, LDVR, + $ WORK( IWRK ), LWORK-IWRK+1, INFO ) + END IF +* +* If INFO > 0 from ZHSEQR, then quit +* + IF( INFO.GT.0 ) + $ GO TO 50 +* + IF( WANTVL .OR. WANTVR ) THEN +* +* Compute left and/or right eigenvectors +* (CWorkspace: need 2*N) +* (RWorkspace: need 2*N) +* + IRWORK = IBAL + N + CALL ZTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ N, NOUT, WORK( IWRK ), RWORK( IRWORK ), IERR ) + END IF +* + IF( WANTVL ) THEN +* +* Undo balancing of left eigenvectors +* (CWorkspace: none) +* (RWorkspace: need N) +* + CALL ZGEBAK( 'B', 'L', N, ILO, IHI, RWORK( IBAL ), N, VL, LDVL, + $ IERR ) +* +* Normalize left eigenvectors and make largest component real +* + DO 20 I = 1, N + SCL = ONE / DZNRM2( N, VL( 1, I ), 1 ) + CALL ZDSCAL( N, SCL, VL( 1, I ), 1 ) + DO 10 K = 1, N + RWORK( IRWORK+K-1 ) = DBLE( VL( K, I ) )**2 + + $ DIMAG( VL( K, I ) )**2 + 10 CONTINUE + K = IDAMAX( N, RWORK( IRWORK ), 1 ) + TMP = DCONJG( VL( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) ) + CALL ZSCAL( N, TMP, VL( 1, I ), 1 ) + VL( K, I ) = DCMPLX( DBLE( VL( K, I ) ), ZERO ) + 20 CONTINUE + END IF +* + IF( WANTVR ) THEN +* +* Undo balancing of right eigenvectors +* (CWorkspace: none) +* (RWorkspace: need N) +* + CALL ZGEBAK( 'B', 'R', N, ILO, IHI, RWORK( IBAL ), N, VR, LDVR, + $ IERR ) +* +* Normalize right eigenvectors and make largest component real +* + DO 40 I = 1, N + SCL = ONE / DZNRM2( N, VR( 1, I ), 1 ) + CALL ZDSCAL( N, SCL, VR( 1, I ), 1 ) + DO 30 K = 1, N + RWORK( IRWORK+K-1 ) = DBLE( VR( K, I ) )**2 + + $ DIMAG( VR( K, I ) )**2 + 30 CONTINUE + K = IDAMAX( N, RWORK( IRWORK ), 1 ) + TMP = DCONJG( VR( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) ) + CALL ZSCAL( N, TMP, VR( 1, I ), 1 ) + VR( K, I ) = DCMPLX( DBLE( VR( K, I ) ), ZERO ) + 40 CONTINUE + END IF +* +* Undo scaling if necessary +* + 50 CONTINUE + IF( SCALEA ) THEN + CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, W( INFO+1 ), + $ MAX( N-INFO, 1 ), IERR ) + IF( INFO.GT.0 ) THEN + CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, W, N, IERR ) + END IF + END IF +* + WORK( 1 ) = MAXWRK + RETURN +* +* End of ZGEEV +* + END diff --git a/2.3-1/src/fortran/lapack/zgehd2.f b/2.3-1/src/fortran/lapack/zgehd2.f new file mode 100644 index 00000000..c73f4200 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgehd2.f @@ -0,0 +1,148 @@ + SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I + COMPLEX*16 ALPHA +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF, ZLARFG +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEHD2', -INFO ) + RETURN + END IF +* + DO 10 I = ILO, IHI - 1 +* +* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) +* + ALPHA = A( I+1, I ) + CALL ZLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAU( I ) ) + A( I+1, I ) = ONE +* +* Apply H(i) to A(1:ihi,i+1:ihi) from the right +* + CALL ZLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), + $ A( 1, I+1 ), LDA, WORK ) +* +* Apply H(i)' to A(i+1:ihi,i+1:n) from the left +* + CALL ZLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, + $ DCONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK ) +* + A( I+1, I ) = ALPHA + 10 CONTINUE +* + RETURN +* +* End of ZGEHD2 +* + END diff --git a/2.3-1/src/fortran/lapack/zgehrd.f b/2.3-1/src/fortran/lapack/zgehrd.f new file mode 100644 index 00000000..83c1aa32 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgehrd.f @@ -0,0 +1,273 @@ + SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB, + $ NBMIN, NH, NX + COMPLEX*16 EI +* .. +* .. Local Arrays .. + COMPLEX*16 T( LDT, NBMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZGEHD2, ZGEMM, ZLAHR2, ZLARFB, ZTRMM, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEHRD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero +* + DO 10 I = 1, ILO - 1 + TAU( I ) = ZERO + 10 CONTINUE + DO 20 I = MAX( 1, IHI ), N - 1 + TAU( I ) = ZERO + 20 CONTINUE +* +* Quick return if possible +* + NH = IHI - ILO + 1 + IF( NH.LE.1 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine the block size +* + NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) + NBMIN = 2 + IWS = 1 + IF( NB.GT.1 .AND. NB.LT.NH ) THEN +* +* Determine when to cross over from blocked to unblocked code +* (last block is always handled by unblocked code) +* + NX = MAX( NB, ILAENV( 3, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) + IF( NX.LT.NH ) THEN +* +* Determine if workspace is large enough for blocked code +* + IWS = N*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: determine the +* minimum value of NB, and reduce NB or force use of +* unblocked code +* + NBMIN = MAX( 2, ILAENV( 2, 'ZGEHRD', ' ', N, ILO, IHI, + $ -1 ) ) + IF( LWORK.GE.N*NBMIN ) THEN + NB = LWORK / N + ELSE + NB = 1 + END IF + END IF + END IF + END IF + LDWORK = N +* + IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN +* +* Use unblocked code below +* + I = ILO +* + ELSE +* +* Use blocked code +* + DO 40 I = ILO, IHI - 1 - NX, NB + IB = MIN( NB, IHI-I ) +* +* 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 +* + CALL ZLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, + $ WORK, 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( I+IB, I+IB-1 ) = ONE + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ IHI, IHI-I-IB+1, + $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, + $ A( 1, I+IB ), LDA ) + A( I+IB, I+IB-1 ) = EI +* +* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the +* right +* + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', I, IB-1, + $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) + DO 30 J = 0, IB-2 + CALL ZAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, + $ A( 1, I+J+1 ), 1 ) + 30 CONTINUE +* +* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the +* left +* + CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward', + $ 'Columnwise', + $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT, + $ A( I+1, I+IB ), LDA, WORK, LDWORK ) + 40 CONTINUE + END IF +* +* Use unblocked code to reduce the rest of the matrix +* + CALL ZGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO ) + WORK( 1 ) = IWS +* + RETURN +* +* End of ZGEHRD +* + END diff --git a/2.3-1/src/fortran/lapack/zgelq2.f b/2.3-1/src/fortran/lapack/zgelq2.f new file mode 100644 index 00000000..dc387af0 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgelq2.f @@ -0,0 +1,123 @@ + SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, K + COMPLEX*16 ALPHA +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGELQ2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = 1, K +* +* Generate elementary reflector H(i) to annihilate A(i,i+1:n) +* + CALL ZLACGV( N-I+1, A( I, I ), LDA ) + ALPHA = A( I, I ) + CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, + $ TAU( I ) ) + IF( I.LT.M ) THEN +* +* Apply H(i) to A(i+1:m,i:n) from the right +* + A( I, I ) = ONE + CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), + $ A( I+1, I ), LDA, WORK ) + END IF + A( I, I ) = ALPHA + CALL ZLACGV( N-I+1, A( I, I ), LDA ) + 10 CONTINUE + RETURN +* +* End of ZGELQ2 +* + END diff --git a/2.3-1/src/fortran/lapack/zgelqf.f b/2.3-1/src/fortran/lapack/zgelqf.f new file mode 100644 index 00000000..5dac50dc --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgelqf.f @@ -0,0 +1,195 @@ + SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGELQ2, ZLARFB, ZLARFT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) + LWKOPT = M*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGELQF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + K = MIN( M, N ) + IF( K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = M + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'ZGELQF', ' ', M, N, -1, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = M + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'ZGELQF', ' ', M, N, -1, + $ -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code initially +* + DO 10 I = 1, K - NX, NB + IB = MIN( K-I+1, NB ) +* +* Compute the LQ factorization of the current block +* A(i:i+ib-1,i:n) +* + CALL ZGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) + IF( I+IB.LE.M ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), + $ LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(i+ib:m,i:n) from the right +* + CALL ZLARFB( 'Right', 'No transpose', 'Forward', + $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), + $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, + $ WORK( IB+1 ), LDWORK ) + END IF + 10 CONTINUE + ELSE + I = 1 + END IF +* +* Use unblocked code to factor the last or only block. +* + IF( I.LE.K ) + $ CALL ZGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* + WORK( 1 ) = IWS + RETURN +* +* End of ZGELQF +* + END diff --git a/2.3-1/src/fortran/lapack/zgelsy.f b/2.3-1/src/fortran/lapack/zgelsy.f new file mode 100644 index 00000000..95aece58 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgelsy.f @@ -0,0 +1,385 @@ + SUBROUTINE ZGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, + $ WORK, LWORK, RWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* 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 .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IASCL, IBSCL, ISMAX, ISMIN, J, LWKOPT, MN, + $ NB, NB1, NB2, NB3, NB4 + DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMAX, SMAXPR, SMIN, SMINPR, + $ SMLNUM, WSIZE + COMPLEX*16 C1, C2, S1, S2 +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, XERBLA, ZCOPY, ZGEQP3, ZLAIC1, ZLASCL, + $ ZLASET, ZTRSM, ZTZRZF, ZUNMQR, ZUNMRZ +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL ILAENV, DLAMCH, ZLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, MAX, MIN +* .. +* .. Executable Statements .. +* + MN = MIN( M, N ) + ISMIN = MN + 1 + ISMAX = 2*MN + 1 +* +* Test the input arguments. +* + INFO = 0 + NB1 = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) + NB2 = ILAENV( 1, 'ZGERQF', ' ', M, N, -1, -1 ) + NB3 = ILAENV( 1, 'ZUNMQR', ' ', M, N, NRHS, -1 ) + NB4 = ILAENV( 1, 'ZUNMRQ', ' ', M, N, NRHS, -1 ) + NB = MAX( NB1, NB2, NB3, NB4 ) + LWKOPT = MAX( 1, MN+2*N+NB*( N+1 ), 2*MN+NB*NRHS ) + WORK( 1 ) = DCMPLX( LWKOPT ) + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN + INFO = -7 + ELSE IF( LWORK.LT.( MN+MAX( 2*MN, N+1, MN+NRHS ) ) .AND. .NOT. + $ LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGELSY', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N, NRHS ).EQ.0 ) THEN + RANK = 0 + RETURN + END IF +* +* Get machine parameters +* + SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* +* Scale A, B if max entries outside range [SMLNUM,BIGNUM] +* + ANRM = ZLANGE( 'M', M, N, A, LDA, RWORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN +* +* Matrix all zero. Return zero solution. +* + CALL ZLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB ) + RANK = 0 + GO TO 70 + END IF +* + BNRM = ZLANGE( 'M', M, NRHS, B, LDB, RWORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL ZLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL ZLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) + IBSCL = 2 + END IF +* +* Compute QR factorization with column pivoting of A: +* A * P = Q * R +* + CALL ZGEQP3( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ), + $ LWORK-MN, RWORK, INFO ) + WSIZE = MN + DBLE( WORK( MN+1 ) ) +* +* 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 +* + WORK( ISMIN ) = CONE + WORK( ISMAX ) = CONE + SMAX = ABS( A( 1, 1 ) ) + SMIN = SMAX + IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN + RANK = 0 + CALL ZLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB ) + GO TO 70 + ELSE + RANK = 1 + END IF +* + 10 CONTINUE + IF( RANK.LT.MN ) THEN + I = RANK + 1 + CALL ZLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ), + $ A( I, I ), SMINPR, S1, C1 ) + CALL ZLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ), + $ A( I, I ), SMAXPR, S2, C2 ) +* + IF( SMAXPR*RCOND.LE.SMINPR ) THEN + DO 20 I = 1, RANK + WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 ) + WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 ) + 20 CONTINUE + WORK( ISMIN+RANK ) = C1 + WORK( ISMAX+RANK ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 10 + END IF + END IF +* +* complex workspace: 3*MN. +* +* Logically partition R = [ R11 R12 ] +* [ 0 R22 ] +* where R11 = R(1:RANK,1:RANK) +* +* [R11,R12] = [ T11, 0 ] * Y +* +c IF( RANK.LT.N ) +c $ CALL ZTZRZF( RANK, N, A, LDA, WORK( MN+1 ), WORK( 2*MN+1 ), +c $ LWORK-2*MN, 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) +* + CALL ZUNMQR( 'Left', 'Conjugate transpose', M, NRHS, MN, A, LDA, + $ WORK( 1 ), B, LDB, WORK( 2*MN+1 ), LWORK-2*MN, INFO ) + WSIZE = MAX( WSIZE, 2*MN+DBLE( WORK( 2*MN+1 ) ) ) +* +* complex workspace: 2*MN+NB*NRHS. +* +* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) +* + CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, + $ NRHS, CONE, A, LDA, B, LDB ) +* + DO 40 J = 1, NRHS + DO 30 I = RANK + 1, N + B( I, J ) = CZERO + 30 CONTINUE + 40 CONTINUE +* +* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) +* +c IF( RANK.LT.N ) THEN +c CALL ZUNMRZ( 'Left', 'Conjugate transpose', N, NRHS, RANK, +c $ N-RANK, A, LDA, WORK( MN+1 ), B, LDB, +c $ WORK( 2*MN+1 ), LWORK-2*MN, INFO ) +c END IF +* +* complex workspace: 2*MN+NRHS. +* +* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) +* + DO 60 J = 1, NRHS + DO 50 I = 1, N + WORK( JPVT( I ) ) = B( I, J ) + 50 CONTINUE + CALL ZCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 ) + 60 CONTINUE +* +* complex workspace: N. +* +* Undo scaling +* + IF( IASCL.EQ.1 ) THEN + CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) + CALL ZLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA, + $ INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) + CALL ZLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA, + $ INFO ) + END IF + IF( IBSCL.EQ.1 ) THEN + CALL ZLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL ZLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) + END IF +* + 70 CONTINUE + WORK( 1 ) = DCMPLX( LWKOPT ) +* + RETURN +* +* End of ZGELSY +* + END diff --git a/2.3-1/src/fortran/lapack/zgeqp3.f b/2.3-1/src/fortran/lapack/zgeqp3.f new file mode 100644 index 00000000..32bf3367 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgeqp3.f @@ -0,0 +1,293 @@ + SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, + $ INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + INTEGER INB, INBMIN, IXOVER + PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, + $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGEQRF, ZLAQP2, ZLAQPS, ZSWAP, ZUNMQR +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DZNRM2 + EXTERNAL ILAENV, DZNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE + IWS = N + 1 + NB = ILAENV( INB, 'ZGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = ( N + 1 )*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEQP3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible. +* + IF( MINMN.EQ.0 ) THEN + RETURN + END IF +* +* Move initial columns up front. +* + NFXD = 1 + DO 10 J = 1, N + IF( JPVT( J ).NE.0 ) THEN + IF( J.NE.NFXD ) THEN + CALL ZSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 ) + JPVT( J ) = JPVT( NFXD ) + JPVT( NFXD ) = J + ELSE + JPVT( J ) = J + END IF + NFXD = NFXD + 1 + ELSE + JPVT( J ) = J + END IF + 10 CONTINUE + NFXD = NFXD - 1 +* +* Factorize fixed columns +* ======================= +* +* Compute the QR factorization of fixed columns and update +* remaining columns. +* + IF( NFXD.GT.0 ) THEN + NA = MIN( M, NFXD ) +*CC CALL ZGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) + CALL ZGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO ) + IWS = MAX( IWS, INT( WORK( 1 ) ) ) + IF( NA.LT.N ) THEN +*CC CALL ZUNM2R( 'Left', 'Conjugate Transpose', M, N-NA, +*CC $ NA, A, LDA, TAU, A( 1, NA+1 ), LDA, WORK, +*CC $ INFO ) + CALL ZUNMQR( 'Left', 'Conjugate Transpose', M, N-NA, NA, A, + $ LDA, TAU, A( 1, NA+1 ), LDA, WORK, LWORK, + $ INFO ) + IWS = MAX( IWS, INT( WORK( 1 ) ) ) + END IF + END IF +* +* Factorize free columns +* ====================== +* + IF( NFXD.LT.MINMN ) THEN +* + SM = M - NFXD + SN = N - NFXD + SMINMN = MINMN - NFXD +* +* Determine the block size. +* + NB = ILAENV( INB, 'ZGEQRF', ' ', SM, SN, -1, -1 ) + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( IXOVER, 'ZGEQRF', ' ', SM, SN, -1, + $ -1 ) ) +* +* + IF( NX.LT.SMINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + MINWS = ( SN+1 )*NB + IWS = MAX( IWS, MINWS ) + IF( LWORK.LT.MINWS ) THEN +* +* Not enough workspace to use optimal NB: Reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / ( SN+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'ZGEQRF', ' ', SM, SN, + $ -1, -1 ) ) +* +* + END IF + END IF + END IF +* +* Initialize partial column norms. The first N elements of work +* store the exact column norms. +* + DO 20 J = NFXD + 1, N + RWORK( J ) = DZNRM2( SM, A( NFXD+1, J ), 1 ) + RWORK( N+J ) = RWORK( J ) + 20 CONTINUE +* + IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. + $ ( NX.LT.SMINMN ) ) THEN +* +* Use blocked code initially. +* + J = NFXD + 1 +* +* Compute factorization: while loop. +* +* + TOPBMN = MINMN - NX + 30 CONTINUE + IF( J.LE.TOPBMN ) THEN + JB = MIN( NB, TOPBMN-J+1 ) +* +* Factorize JB columns among columns J:N. +* + CALL ZLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, + $ JPVT( J ), TAU( J ), RWORK( J ), + $ RWORK( N+J ), WORK( 1 ), WORK( JB+1 ), + $ N-J+1 ) +* + J = J + FJB + GO TO 30 + END IF + ELSE + J = NFXD + 1 + END IF +* +* Use unblocked code to factor the last or only block. +* +* + IF( J.LE.MINMN ) + $ CALL ZLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), + $ TAU( J ), RWORK( J ), RWORK( N+J ), WORK( 1 ) ) +* + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of ZGEQP3 +* + END diff --git a/2.3-1/src/fortran/lapack/zgeqpf.f b/2.3-1/src/fortran/lapack/zgeqpf.f new file mode 100644 index 00000000..6d4f86f0 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgeqpf.f @@ -0,0 +1,234 @@ + SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) +* +* -- LAPACK deprecated driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, MA, MN, PVT + DOUBLE PRECISION TEMP, TEMP2, TOL3Z + COMPLEX*16 AII +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGEQR2, ZLARF, ZLARFG, ZSWAP, ZUNM2R +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DCMPLX, DCONJG, MAX, MIN, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL IDAMAX, DLAMCH, DZNRM2 +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEQPF', -INFO ) + RETURN + END IF +* + MN = MIN( M, N ) + TOL3Z = SQRT(DLAMCH('Epsilon')) +* +* Move initial columns up front +* + ITEMP = 1 + DO 10 I = 1, N + IF( JPVT( I ).NE.0 ) THEN + IF( I.NE.ITEMP ) THEN + CALL ZSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 ) + JPVT( I ) = JPVT( ITEMP ) + JPVT( ITEMP ) = I + ELSE + JPVT( I ) = I + END IF + ITEMP = ITEMP + 1 + ELSE + JPVT( I ) = I + END IF + 10 CONTINUE + ITEMP = ITEMP - 1 +* +* Compute the QR factorization and update remaining columns +* + IF( ITEMP.GT.0 ) THEN + MA = MIN( ITEMP, M ) + CALL ZGEQR2( M, MA, A, LDA, TAU, WORK, INFO ) + IF( MA.LT.N ) THEN + CALL ZUNM2R( 'Left', 'Conjugate transpose', M, N-MA, MA, A, + $ LDA, TAU, A( 1, MA+1 ), LDA, WORK, INFO ) + END IF + END IF +* + IF( ITEMP.LT.MN ) THEN +* +* Initialize partial column norms. The first n elements of +* work store the exact column norms. +* + DO 20 I = ITEMP + 1, N + RWORK( I ) = DZNRM2( M-ITEMP, A( ITEMP+1, I ), 1 ) + RWORK( N+I ) = RWORK( I ) + 20 CONTINUE +* +* Compute factorization +* + DO 40 I = ITEMP + 1, MN +* +* Determine ith pivot column and swap if necessary +* + PVT = ( I-1 ) + IDAMAX( N-I+1, RWORK( I ), 1 ) +* + IF( PVT.NE.I ) THEN + CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( I ) + JPVT( I ) = ITEMP + RWORK( PVT ) = RWORK( I ) + RWORK( N+PVT ) = RWORK( N+I ) + END IF +* +* Generate elementary reflector H(i) +* + AII = A( I, I ) + CALL ZLARFG( M-I+1, AII, A( MIN( I+1, M ), I ), 1, + $ TAU( I ) ) + A( I, I ) = AII +* + IF( I.LT.N ) THEN +* +* Apply H(i) to A(i:m,i+1:n) from the left +* + AII = A( I, I ) + A( I, I ) = DCMPLX( ONE ) + CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, + $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) + A( I, I ) = AII + END IF +* +* Update partial column norms +* + DO 30 J = I + 1, N + IF( RWORK( J ).NE.ZERO ) THEN +* +* NOTE: The following 4 lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ABS( A( I, J ) ) / RWORK( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( RWORK( J ) / RWORK( N+J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN + IF( M-I.GT.0 ) THEN + RWORK( J ) = DZNRM2( M-I, A( I+1, J ), 1 ) + RWORK( N+J ) = RWORK( J ) + ELSE + RWORK( J ) = ZERO + RWORK( N+J ) = ZERO + END IF + ELSE + RWORK( J ) = RWORK( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE +* + 40 CONTINUE + END IF + RETURN +* +* End of ZGEQPF +* + END diff --git a/2.3-1/src/fortran/lapack/zgeqr2.f b/2.3-1/src/fortran/lapack/zgeqr2.f new file mode 100644 index 00000000..962ab588 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgeqr2.f @@ -0,0 +1,121 @@ + SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, K + COMPLEX*16 ALPHA +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF, ZLARFG +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEQR2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = 1, K +* +* Generate elementary reflector H(i) to annihilate A(i+1:m,i) +* + CALL ZLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, + $ TAU( I ) ) + IF( I.LT.N ) THEN +* +* Apply H(i)' to A(i:m,i+1:n) from the left +* + ALPHA = A( I, I ) + A( I, I ) = ONE + CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, + $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) + A( I, I ) = ALPHA + END IF + 10 CONTINUE + RETURN +* +* End of ZGEQR2 +* + END diff --git a/2.3-1/src/fortran/lapack/zgeqrf.f b/2.3-1/src/fortran/lapack/zgeqrf.f new file mode 100644 index 00000000..d11c9245 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgeqrf.f @@ -0,0 +1,196 @@ + SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGEQR2, ZLARFB, ZLARFT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEQRF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + K = MIN( M, N ) + IF( K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'ZGEQRF', ' ', M, N, -1, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'ZGEQRF', ' ', M, N, -1, + $ -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code initially +* + DO 10 I = 1, K - NX, NB + IB = MIN( K-I+1, NB ) +* +* Compute the QR factorization of the current block +* A(i:m,i:i+ib-1) +* + CALL ZGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) + IF( I+IB.LE.N ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, + $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H' to A(i:m,i+ib:n) from the left +* + CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward', + $ 'Columnwise', M-I+1, N-I-IB+1, IB, + $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), + $ LDA, WORK( IB+1 ), LDWORK ) + END IF + 10 CONTINUE + ELSE + I = 1 + END IF +* +* Use unblocked code to factor the last or only block. +* + IF( I.LE.K ) + $ CALL ZGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* + WORK( 1 ) = IWS + RETURN +* +* End of ZGEQRF +* + END diff --git a/2.3-1/src/fortran/lapack/zgesc2.f b/2.3-1/src/fortran/lapack/zgesc2.f new file mode 100644 index 00000000..d4d51337 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgesc2.f @@ -0,0 +1,133 @@ + SUBROUTINE ZGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER LDA, N + DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), JPIV( * ) + COMPLEX*16 A( LDA, * ), RHS( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION BIGNUM, EPS, SMLNUM + COMPLEX*16 TEMP +* .. +* .. External Subroutines .. + EXTERNAL ZLASWP, ZSCAL +* .. +* .. External Functions .. + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL IZAMAX, DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX +* .. +* .. Executable Statements .. +* +* Set constant to control overflow +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* +* Apply permutations IPIV to RHS +* + CALL ZLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 ) +* +* Solve for L part +* + DO 20 I = 1, N - 1 + DO 10 J = I + 1, N + RHS( J ) = RHS( J ) - A( J, I )*RHS( I ) + 10 CONTINUE + 20 CONTINUE +* +* Solve for U part +* + SCALE = ONE +* +* Check for scaling +* + I = IZAMAX( N, RHS, 1 ) + IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN + TEMP = DCMPLX( ONE / TWO, ZERO ) / ABS( RHS( I ) ) + CALL ZSCAL( N, TEMP, RHS( 1 ), 1 ) + SCALE = SCALE*DBLE( TEMP ) + END IF + DO 40 I = N, 1, -1 + TEMP = DCMPLX( ONE, ZERO ) / A( I, I ) + RHS( I ) = RHS( I )*TEMP + DO 30 J = I + 1, N + RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP ) + 30 CONTINUE + 40 CONTINUE +* +* Apply permutations JPIV to the solution (RHS) +* + CALL ZLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 ) + RETURN +* +* End of ZGESC2 +* + END diff --git a/2.3-1/src/fortran/lapack/zgesvd.f b/2.3-1/src/fortran/lapack/zgesvd.f new file mode 100644 index 00000000..7b238d8b --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgesvd.f @@ -0,0 +1,3602 @@ + SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, RWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBU, JOBVT + INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION RWORK( * ), S( * ) + COMPLEX*16 A( LDA, * ), U( LDU, * ), VT( LDVT, * ), + $ WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), + $ CONE = ( 1.0D0, 0.0D0 ) ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, + $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS + INTEGER BLK, CHUNK, I, IE, IERR, IR, IRWORK, ISCL, + $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU, + $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU, + $ NRVT, WRKBL + DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM +* .. +* .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ) + COMPLEX*16 CDUM( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DLASCL, XERBLA, ZBDSQR, ZGEBRD, ZGELQF, ZGEMM, + $ ZGEQRF, ZLACPY, ZLASCL, ZLASET, ZUNGBR, ZUNGLQ, + $ ZUNGQR, ZUNMBR +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + MINMN = MIN( M, N ) + WNTUA = LSAME( JOBU, 'A' ) + WNTUS = LSAME( JOBU, 'S' ) + WNTUAS = WNTUA .OR. WNTUS + WNTUO = LSAME( JOBU, 'O' ) + WNTUN = LSAME( JOBU, 'N' ) + WNTVA = LSAME( JOBVT, 'A' ) + WNTVS = LSAME( JOBVT, 'S' ) + WNTVAS = WNTVA .OR. WNTVS + WNTVO = LSAME( JOBVT, 'O' ) + WNTVN = LSAME( JOBVT, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* + IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN + INFO = -1 + ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR. + $ ( WNTVO .AND. WNTUO ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN + INFO = -9 + ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR. + $ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN + INFO = -11 + END IF +* +* 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.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + IF( M.GE.N .AND. MINMN.GT.0 ) THEN +* +* Space needed for ZBDSQR is BDSPAC = 5*N +* + MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) + IF( M.GE.MNTHR ) THEN + IF( WNTUN ) THEN +* +* Path 1 (M much larger than N, JOBU='N') +* + MAXWRK = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, + $ -1 ) + MAXWRK = MAX( MAXWRK, 2*N+2*N* + $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) + IF( WNTVO .OR. WNTVAS ) + $ MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* + $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) + MINWRK = 3*N + ELSE IF( WNTUO .AND. WNTVN ) THEN +* +* Path 2 (M much larger than N, JOBU='O', JOBVT='N') +* + WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, + $ N, N, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+2*N* + $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+N* + $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) + MAXWRK = MAX( N*N+WRKBL, N*N+M*N ) + MINWRK = 2*N + M + ELSE IF( WNTUO .AND. WNTVAS ) THEN +* +* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or +* 'A') +* + WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, + $ N, N, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+2*N* + $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+N* + $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+( N-1 )* + $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) + MAXWRK = MAX( N*N+WRKBL, N*N+M*N ) + MINWRK = 2*N + M + ELSE IF( WNTUS .AND. WNTVN ) THEN +* +* Path 4 (M much larger than N, JOBU='S', JOBVT='N') +* + WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, + $ N, N, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+2*N* + $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+N* + $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) + MAXWRK = N*N + WRKBL + MINWRK = 2*N + M + ELSE IF( WNTUS .AND. WNTVO ) THEN +* +* Path 5 (M much larger than N, JOBU='S', JOBVT='O') +* + WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, + $ N, N, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+2*N* + $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+N* + $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+( N-1 )* + $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) + MAXWRK = 2*N*N + WRKBL + MINWRK = 2*N + M + ELSE IF( WNTUS .AND. WNTVAS ) THEN +* +* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or +* 'A') +* + WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, + $ N, N, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+2*N* + $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+N* + $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+( N-1 )* + $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) + MAXWRK = N*N + WRKBL + MINWRK = 2*N + M + ELSE IF( WNTUA .AND. WNTVN ) THEN +* +* Path 7 (M much larger than N, JOBU='A', JOBVT='N') +* + WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M, + $ M, N, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+2*N* + $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+N* + $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) + MAXWRK = N*N + WRKBL + MINWRK = 2*N + M + ELSE IF( WNTUA .AND. WNTVO ) THEN +* +* Path 8 (M much larger than N, JOBU='A', JOBVT='O') +* + WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M, + $ M, N, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+2*N* + $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+N* + $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+( N-1 )* + $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) + MAXWRK = 2*N*N + WRKBL + MINWRK = 2*N + M + ELSE IF( WNTUA .AND. WNTVAS ) THEN +* +* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or +* 'A') +* + WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M, + $ M, N, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+2*N* + $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+N* + $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, 2*N+( N-1 )* + $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) + MAXWRK = N*N + WRKBL + MINWRK = 2*N + M + END IF + ELSE +* +* Path 10 (M at least N, but not much larger) +* + MAXWRK = 2*N + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N, + $ -1, -1 ) + IF( WNTUS .OR. WNTUO ) + $ MAXWRK = MAX( MAXWRK, 2*N+N* + $ ILAENV( 1, 'ZUNGBR', 'Q', M, N, N, -1 ) ) + IF( WNTUA ) + $ MAXWRK = MAX( MAXWRK, 2*N+M* + $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) ) + IF( .NOT.WNTVN ) + $ MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* + $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) + MINWRK = 2*N + M + END IF + ELSE IF( MINMN.GT.0 ) THEN +* +* Space needed for ZBDSQR is BDSPAC = 5*M +* + MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) + IF( N.GE.MNTHR ) THEN + IF( WNTVN ) THEN +* +* Path 1t(N much larger than M, JOBVT='N') +* + MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, + $ -1 ) + MAXWRK = MAX( MAXWRK, 2*M+2*M* + $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) + IF( WNTUO .OR. WNTUAS ) + $ MAXWRK = MAX( MAXWRK, 2*M+M* + $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) + MINWRK = 3*M + ELSE IF( WNTVO .AND. WNTUN ) THEN +* +* Path 2t(N much larger than M, JOBU='N', JOBVT='O') +* + WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+2*M* + $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+( M-1 )* + $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) + MAXWRK = MAX( M*M+WRKBL, M*M+M*N ) + MINWRK = 2*M + N + ELSE IF( WNTVO .AND. WNTUAS ) THEN +* +* Path 3t(N much larger than M, JOBU='S' or 'A', +* JOBVT='O') +* + WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+2*M* + $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+( M-1 )* + $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+M* + $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) + MAXWRK = MAX( M*M+WRKBL, M*M+M*N ) + MINWRK = 2*M + N + ELSE IF( WNTVS .AND. WNTUN ) THEN +* +* Path 4t(N much larger than M, JOBU='N', JOBVT='S') +* + WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+2*M* + $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+( M-1 )* + $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) + MAXWRK = M*M + WRKBL + MINWRK = 2*M + N + ELSE IF( WNTVS .AND. WNTUO ) THEN +* +* Path 5t(N much larger than M, JOBU='O', JOBVT='S') +* + WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+2*M* + $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+( M-1 )* + $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+M* + $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) + MAXWRK = 2*M*M + WRKBL + MINWRK = 2*M + N + ELSE IF( WNTVS .AND. WNTUAS ) THEN +* +* Path 6t(N much larger than M, JOBU='S' or 'A', +* JOBVT='S') +* + WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+2*M* + $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+( M-1 )* + $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+M* + $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) + MAXWRK = M*M + WRKBL + MINWRK = 2*M + N + ELSE IF( WNTVA .AND. WNTUN ) THEN +* +* Path 7t(N much larger than M, JOBU='N', JOBVT='A') +* + WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+2*M* + $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+( M-1 )* + $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) + MAXWRK = M*M + WRKBL + MINWRK = 2*M + N + ELSE IF( WNTVA .AND. WNTUO ) THEN +* +* Path 8t(N much larger than M, JOBU='O', JOBVT='A') +* + WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+2*M* + $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+( M-1 )* + $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+M* + $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) + MAXWRK = 2*M*M + WRKBL + MINWRK = 2*M + N + ELSE IF( WNTVA .AND. WNTUAS ) THEN +* +* Path 9t(N much larger than M, JOBU='S' or 'A', +* JOBVT='A') +* + WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+2*M* + $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+( M-1 )* + $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, 2*M+M* + $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) + MAXWRK = M*M + WRKBL + MINWRK = 2*M + N + END IF + ELSE +* +* Path 10t(N greater than M, but not much larger) +* + MAXWRK = 2*M + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N, + $ -1, -1 ) + IF( WNTVS .OR. WNTVO ) + $ MAXWRK = MAX( MAXWRK, 2*M+M* + $ ILAENV( 1, 'ZUNGBR', 'P', M, N, M, -1 ) ) + IF( WNTVA ) + $ MAXWRK = MAX( MAXWRK, 2*M+N* + $ ILAENV( 1, 'ZUNGBR', 'P', N, N, M, -1 ) ) + IF( .NOT.WNTUN ) + $ MAXWRK = MAX( MAXWRK, 2*M+( M-1 )* + $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) + MINWRK = 2*M + N + END IF + END IF + MAXWRK = MAX( MAXWRK, MINWRK ) + WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGESVD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + RETURN + END IF +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = ZLANGE( 'M', M, N, A, LDA, DUM ) + ISCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ISCL = 1 + CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR ) + ELSE IF( ANRM.GT.BIGNUM ) THEN + ISCL = 1 + CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR ) + END IF +* + IF( M.GE.N ) THEN +* +* 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.GE.MNTHR ) THEN +* + IF( WNTUN ) THEN +* +* 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) +* + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Zero out below R +* + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ), + $ 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) +* + CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, + $ IERR ) + NCVT = 0 + IF( WNTVO .OR. WNTVAS ) THEN +* +* If right singular vectors desired, generate P'. +* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + NCVT = N + END IF + IRWORK = IE + N +* +* Perform bidiagonal QR iteration, computing right +* singular vectors of A in A if desired +* (CWorkspace: 0) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'U', N, NCVT, 0, 0, S, RWORK( IE ), A, LDA, + $ CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO ) +* +* If right singular vectors desired in VT, copy them there +* + IF( WNTVAS ) + $ CALL ZLACPY( 'F', N, N, A, LDA, VT, LDVT ) +* + ELSE IF( WNTUO .AND. WNTVN ) THEN +* +* 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.GE.N*N+3*N ) THEN +* +* Sufficient workspace for a fast algorithm +* + IR = 1 + IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN +* +* WORK(IU) is LDA by N, WORK(IR) is LDA by N +* + LDWRKU = LDA + LDWRKR = LDA + ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN +* +* 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 + END IF + 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) +* + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to WORK(IR) and zero out below it +* + CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR ) + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ WORK( IR+1 ), LDWRKR ) +* +* Generate Q in A +* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Generate left vectors bidiagonalizing R +* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) +* (RWorkspace: need 0) +* + CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + IRWORK = IE + N +* +* Perform bidiagonal QR iteration, computing left +* singular vectors of R in WORK(IR) +* (CWorkspace: need N*N) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, 1, + $ WORK( IR ), LDWRKR, CDUM, 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) +* + DO 10 I = 1, M, LDWRKU + CHUNK = MIN( M-I+1, LDWRKU ) + CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ), + $ LDA, WORK( IR ), LDWRKR, CZERO, + $ WORK( IU ), LDWRKU ) + CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, + $ A( I, 1 ), LDA ) + 10 CONTINUE +* + 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) +* + CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Generate left vectors bidiagonalizing A +* (CWorkspace: need 3*N, prefer 2*N+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IRWORK = IE + N +* +* Perform bidiagonal QR iteration, computing left +* singular vectors of A in A +* (CWorkspace: need 0) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, 1, + $ A, LDA, CDUM, 1, RWORK( IRWORK ), INFO ) +* + END IF +* + ELSE IF( WNTUO .AND. WNTVAS ) THEN +* +* 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.GE.N*N+3*N ) THEN +* +* Sufficient workspace for a fast algorithm +* + IR = 1 + IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN +* +* WORK(IU) is LDA by N and WORK(IR) is LDA by N +* + LDWRKU = LDA + LDWRKR = LDA + ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN +* +* 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 + END IF + 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) +* + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to VT, zeroing out below it +* + CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) + IF( N.GT.1 ) + $ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ VT( 2, 1 ), LDVT ) +* +* Generate Q in A +* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'L', N, N, VT, 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) +* + CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT, + $ LDVT, WORK( IR ), LDWRKR, CDUM, 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) +* + DO 20 I = 1, M, LDWRKU + CHUNK = MIN( M-I+1, LDWRKU ) + CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ), + $ LDA, WORK( IR ), LDWRKR, CZERO, + $ WORK( IU ), LDWRKU ) + CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, + $ A( I, 1 ), LDA ) + 20 CONTINUE +* + 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) +* + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to VT, zeroing out below it +* + CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) + IF( N.GT.1 ) + $ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ VT( 2, 1 ), LDVT ) +* +* Generate Q in A +* (CWorkspace: need 2*N, prefer N+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply Q in A by left vectors bidiagonalizing R +* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) +* (RWorkspace: 0) +* + CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, + $ WORK( ITAUQ ), A, LDA, WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate right vectors bidiagonalizing R in VT +* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT, + $ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ), + $ INFO ) +* + END IF +* + ELSE IF( WNTUS ) THEN +* + IF( WNTVN ) THEN +* +* 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.GE.N*N+3*N ) THEN +* +* Sufficient workspace for a fast algorithm +* + IR = 1 + IF( LWORK.GE.WRKBL+LDA*N ) THEN +* +* WORK(IR) is LDA by N +* + LDWRKR = LDA + ELSE +* +* WORK(IR) is N by N +* + LDWRKR = N + END IF + 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) +* + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to WORK(IR), zeroing out below it +* + CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), + $ LDWRKR ) + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ WORK( IR+1 ), LDWRKR ) +* +* Generate Q in A +* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, + $ RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate left vectors bidiagonalizing R in WORK(IR) +* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + IRWORK = IE + N +* +* Perform bidiagonal QR iteration, computing left +* singular vectors of R in WORK(IR) +* (CWorkspace: need N*N) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, + $ 1, WORK( IR ), LDWRKR, CDUM, 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) +* + CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA, + $ WORK( IR ), LDWRKR, CZERO, U, 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) +* + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (CWorkspace: need 2*N, prefer N+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IE = 1 + ITAUQ = ITAU + ITAUP = ITAUQ + N + IWORK = ITAUP + N +* +* Zero out below R in A +* + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ A( 2, 1 ), LDA ) +* +* Bidiagonalize R in A +* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) +* (RWorkspace: need N) +* + CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply Q in U by left vectors bidiagonalizing R +* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) +* (RWorkspace: 0) +* + CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + IRWORK = IE + N +* +* Perform bidiagonal QR iteration, computing left +* singular vectors of A in U +* (CWorkspace: 0) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, + $ 1, U, LDU, CDUM, 1, RWORK( IRWORK ), + $ INFO ) +* + END IF +* + ELSE IF( WNTVO ) THEN +* +* 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.GE.2*N*N+3*N ) THEN +* +* Sufficient workspace for a fast algorithm +* + IU = 1 + IF( LWORK.GE.WRKBL+2*LDA*N ) THEN +* +* WORK(IU) is LDA by N and WORK(IR) is LDA by N +* + LDWRKU = LDA + IR = IU + LDWRKU*N + LDWRKR = LDA + ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN +* +* 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 + END IF + 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) +* + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to WORK(IU), zeroing out below it +* + CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ), + $ LDWRKU ) + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ WORK( IU+1 ), LDWRKU ) +* +* Generate Q in A +* (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S, + $ RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + CALL 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) +* + CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), + $ WORK( IR ), LDWRKR, WORK( IU ), + $ LDWRKU, CDUM, 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) +* + CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA, + $ WORK( IU ), LDWRKU, CZERO, U, LDU ) +* +* Copy right singular vectors of R to A +* (CWorkspace: need N*N) +* (RWorkspace: 0) +* + CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, + $ 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) +* + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (CWorkspace: need 2*N, prefer N+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IE = 1 + ITAUQ = ITAU + ITAUP = ITAUQ + N + IWORK = ITAUP + N +* +* Zero out below R in A +* + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ A( 2, 1 ), LDA ) +* +* Bidiagonalize R in A +* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) +* (RWorkspace: need N) +* + CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply Q in U by left vectors bidiagonalizing R +* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) +* (RWorkspace: 0) +* + CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate right vectors bidiagonalizing R in A +* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A, + $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ), + $ INFO ) +* + END IF +* + ELSE IF( WNTVAS ) THEN +* +* 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.GE.N*N+3*N ) THEN +* +* Sufficient workspace for a fast algorithm +* + IU = 1 + IF( LWORK.GE.WRKBL+LDA*N ) THEN +* +* WORK(IU) is LDA by N +* + LDWRKU = LDA + ELSE +* +* WORK(IU) is N by N +* + LDWRKU = N + END IF + 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) +* + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to WORK(IU), zeroing out below it +* + CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ), + $ LDWRKU ) + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ WORK( IU+1 ), LDWRKU ) +* +* Generate Q in A +* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S, + $ RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, + $ LDVT ) +* +* Generate left bidiagonalizing vectors in WORK(IU) +* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate right bidiagonalizing vectors in VT +* (CWorkspace: need N*N+3*N-1, +* prefer N*N+2*N+(N-1)*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT, + $ LDVT, WORK( IU ), LDWRKU, CDUM, 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) +* + CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA, + $ WORK( IU ), LDWRKU, CZERO, U, 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) +* + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (CWorkspace: need 2*N, prefer N+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to VT, zeroing out below it +* + CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) + IF( N.GT.1 ) + $ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ VT( 2, 1 ), 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) +* + CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply Q in U by left bidiagonalizing vectors +* in VT +* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) +* (RWorkspace: 0) +* + CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, + $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate right bidiagonalizing vectors in VT +* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT, + $ LDVT, U, LDU, CDUM, 1, + $ RWORK( IRWORK ), INFO ) +* + END IF +* + END IF +* + ELSE IF( WNTUA ) THEN +* + IF( WNTVN ) THEN +* +* 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 +* + IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IR = 1 + IF( LWORK.GE.WRKBL+LDA*N ) THEN +* +* WORK(IR) is LDA by N +* + LDWRKR = LDA + ELSE +* +* WORK(IR) is N by N +* + LDWRKR = N + END IF + 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) +* + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Copy R to WORK(IR), zeroing out below it +* + CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), + $ LDWRKR ) + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ WORK( IR+1 ), LDWRKR ) +* +* Generate Q in U +* (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, + $ RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate left bidiagonalizing vectors in WORK(IR) +* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + IRWORK = IE + N +* +* Perform bidiagonal QR iteration, computing left +* singular vectors of R in WORK(IR) +* (CWorkspace: need N*N) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, + $ 1, WORK( IR ), LDWRKR, CDUM, 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) +* + CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU, + $ WORK( IR ), LDWRKR, CZERO, A, LDA ) +* +* Copy left singular vectors of A from A to U +* + CALL ZLACPY( 'F', M, N, A, LDA, U, 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) +* + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (CWorkspace: need N+M, prefer N+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IE = 1 + ITAUQ = ITAU + ITAUP = ITAUQ + N + IWORK = ITAUP + N +* +* Zero out below R in A +* + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ A( 2, 1 ), LDA ) +* +* Bidiagonalize R in A +* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) +* (RWorkspace: need N) +* + CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply Q in U by left bidiagonalizing vectors +* in A +* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) +* (RWorkspace: 0) +* + CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + IRWORK = IE + N +* +* Perform bidiagonal QR iteration, computing left +* singular vectors of A in U +* (CWorkspace: 0) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, + $ 1, U, LDU, CDUM, 1, RWORK( IRWORK ), + $ INFO ) +* + END IF +* + ELSE IF( WNTVO ) THEN +* +* 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 +* + IF( LWORK.GE.2*N*N+MAX( N+M, 3*N ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IU = 1 + IF( LWORK.GE.WRKBL+2*LDA*N ) THEN +* +* WORK(IU) is LDA by N and WORK(IR) is LDA by N +* + LDWRKU = LDA + IR = IU + LDWRKU*N + LDWRKR = LDA + ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN +* +* 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 + END IF + 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) +* + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (CWorkspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to WORK(IU), zeroing out below it +* + CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ), + $ LDWRKU ) + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ 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) +* + CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S, + $ RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + CALL 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) +* + CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), + $ WORK( IR ), LDWRKR, WORK( IU ), + $ LDWRKU, CDUM, 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) +* + CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU, + $ WORK( IU ), LDWRKU, CZERO, A, LDA ) +* +* Copy left singular vectors of A from A to U +* + CALL ZLACPY( 'F', M, N, A, LDA, U, LDU ) +* +* Copy right singular vectors of R from WORK(IR) to A +* + CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, + $ 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) +* + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (CWorkspace: need N+M, prefer N+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IE = 1 + ITAUQ = ITAU + ITAUP = ITAUQ + N + IWORK = ITAUP + N +* +* Zero out below R in A +* + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ A( 2, 1 ), LDA ) +* +* Bidiagonalize R in A +* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) +* (RWorkspace: need N) +* + CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply Q in U by left bidiagonalizing vectors +* in A +* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) +* (RWorkspace: 0) +* + CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate right bidiagonalizing vectors in A +* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A, + $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ), + $ INFO ) +* + END IF +* + ELSE IF( WNTVAS ) THEN +* +* 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 +* + IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IU = 1 + IF( LWORK.GE.WRKBL+LDA*N ) THEN +* +* WORK(IU) is LDA by N +* + LDWRKU = LDA + ELSE +* +* WORK(IU) is N by N +* + LDWRKU = N + END IF + 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) +* + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R to WORK(IU), zeroing out below it +* + CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ), + $ LDWRKU ) + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ 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) +* + CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S, + $ RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, + $ LDVT ) +* +* Generate left bidiagonalizing vectors in WORK(IU) +* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT, + $ LDVT, WORK( IU ), LDWRKU, CDUM, 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) +* + CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU, + $ WORK( IU ), LDWRKU, CZERO, A, LDA ) +* +* Copy left singular vectors of A from A to U +* + CALL ZLACPY( 'F', M, N, A, LDA, U, 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) +* + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (CWorkspace: need N+M, prefer N+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy R from A to VT, zeroing out below it +* + CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) + IF( N.GT.1 ) + $ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ VT( 2, 1 ), 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) +* + CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply Q in U by left bidiagonalizing vectors +* in VT +* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) +* (RWorkspace: 0) +* + CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, + $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate right bidiagonalizing vectors in VT +* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT, + $ LDVT, U, LDU, CDUM, 1, + $ RWORK( IRWORK ), INFO ) +* + END IF +* + END IF +* + END IF +* + 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) +* + CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, + $ IERR ) + IF( WNTUAS ) THEN +* +* 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) +* + CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) + IF( WNTUS ) + $ NCU = N + IF( WNTUA ) + $ NCU = M + CALL ZUNGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IF( WNTVAS ) THEN +* +* 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) +* + CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) + CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IF( WNTUO ) THEN +* +* If left singular vectors desired in A, generate left +* bidiagonalizing vectors in A +* (CWorkspace: need 3*N, prefer 2*N+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IF( WNTVO ) THEN +* +* 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) +* + CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IRWORK = IE + N + IF( WNTUAS .OR. WNTUO ) + $ NRU = M + IF( WNTUN ) + $ NRU = 0 + IF( WNTVAS .OR. WNTVO ) + $ NCVT = N + IF( WNTVN ) + $ NCVT = 0 + IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN +* +* Perform bidiagonal QR iteration, if desired, computing +* left singular vectors in U and computing right singular +* vectors in VT +* (CWorkspace: 0) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT, + $ LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ), + $ INFO ) + ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN +* +* Perform bidiagonal QR iteration, if desired, computing +* left singular vectors in U and computing right singular +* vectors in A +* (CWorkspace: 0) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), A, + $ LDA, U, LDU, CDUM, 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) +* + CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT, + $ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ), + $ INFO ) + END IF +* + END IF +* + 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.GE.MNTHR ) THEN +* + IF( WNTVN ) THEN +* +* 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) +* + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Zero out above L +* + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, A( 1, 2 ), + $ 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) +* + CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, + $ IERR ) + IF( WNTUO .OR. WNTUAS ) THEN +* +* If left singular vectors desired, generate Q +* (CWorkspace: need 3*M, prefer 2*M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IRWORK = IE + M + NRU = 0 + IF( WNTUO .OR. WNTUAS ) + $ NRU = M +* +* Perform bidiagonal QR iteration, computing left singular +* vectors of A in A if desired +* (CWorkspace: 0) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'U', M, 0, NRU, 0, S, RWORK( IE ), CDUM, 1, + $ A, LDA, CDUM, 1, RWORK( IRWORK ), INFO ) +* +* If left singular vectors desired in U, copy them there +* + IF( WNTUAS ) + $ CALL ZLACPY( 'F', M, M, A, LDA, U, LDU ) +* + ELSE IF( WNTVO .AND. WNTUN ) THEN +* +* 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.GE.M*M+3*M ) THEN +* +* Sufficient workspace for a fast algorithm +* + IR = 1 + IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN +* +* WORK(IU) is LDA by N and WORK(IR) is LDA by M +* + LDWRKU = LDA + CHUNK = N + LDWRKR = LDA + ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN +* +* 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 + END IF + 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) +* + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to WORK(IR) and zero out above it +* + CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR ) + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, + $ WORK( IR+LDWRKR ), LDWRKR ) +* +* Generate Q in A +* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Generate right vectors bidiagonalizing L +* (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + IRWORK = IE + M +* +* Perform bidiagonal QR iteration, computing right +* singular vectors of L in WORK(IR) +* (CWorkspace: need M*M) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ), + $ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 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) +* + DO 30 I = 1, N, CHUNK + BLK = MIN( N-I+1, CHUNK ) + CALL ZGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ), + $ LDWRKR, A( 1, I ), LDA, CZERO, + $ WORK( IU ), LDWRKU ) + CALL ZLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, + $ A( 1, I ), LDA ) + 30 CONTINUE +* + 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) +* + CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Generate right vectors bidiagonalizing A +* (CWorkspace: need 3*M, prefer 2*M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IRWORK = IE + M +* +* Perform bidiagonal QR iteration, computing right +* singular vectors of A in A +* (CWorkspace: 0) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'L', M, N, 0, 0, S, RWORK( IE ), A, LDA, + $ CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO ) +* + END IF +* + ELSE IF( WNTVO .AND. WNTUAS ) THEN +* +* 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.GE.M*M+3*M ) THEN +* +* Sufficient workspace for a fast algorithm +* + IR = 1 + IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN +* +* WORK(IU) is LDA by N and WORK(IR) is LDA by M +* + LDWRKU = LDA + CHUNK = N + LDWRKR = LDA + ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN +* +* 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 + END IF + 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) +* + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to U, zeroing about above it +* + CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ), + $ LDU ) +* +* Generate Q in A +* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'U', M, M, U, 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) +* + CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate left vectors bidiagonalizing L in U +* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), + $ WORK( IR ), LDWRKR, U, LDU, CDUM, 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) +* + DO 40 I = 1, N, CHUNK + BLK = MIN( N-I+1, CHUNK ) + CALL ZGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ), + $ LDWRKR, A( 1, I ), LDA, CZERO, + $ WORK( IU ), LDWRKU ) + CALL ZLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, + $ A( 1, I ), LDA ) + 40 CONTINUE +* + 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) +* + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to U, zeroing out above it +* + CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ), + $ LDU ) +* +* Generate Q in A +* (CWorkspace: need 2*M, prefer M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply right vectors bidiagonalizing L by Q in A +* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) +* (RWorkspace: 0) +* + CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU, + $ WORK( ITAUP ), A, LDA, WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate left vectors bidiagonalizing L in U +* (CWorkspace: need 3*M, prefer 2*M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), A, LDA, + $ U, LDU, CDUM, 1, RWORK( IRWORK ), INFO ) +* + END IF +* + ELSE IF( WNTVS ) THEN +* + IF( WNTUN ) THEN +* +* 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.GE.M*M+3*M ) THEN +* +* Sufficient workspace for a fast algorithm +* + IR = 1 + IF( LWORK.GE.WRKBL+LDA*M ) THEN +* +* WORK(IR) is LDA by M +* + LDWRKR = LDA + ELSE +* +* WORK(IR) is M by M +* + LDWRKR = M + END IF + 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) +* + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to WORK(IR), zeroing out above it +* + CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), + $ LDWRKR ) + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, + $ WORK( IR+LDWRKR ), LDWRKR ) +* +* Generate Q in A +* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, + $ RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + IRWORK = IE + M +* +* Perform bidiagonal QR iteration, computing right +* singular vectors of L in WORK(IR) +* (CWorkspace: need M*M) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ), + $ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 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) +* + CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ), + $ LDWRKR, A, LDA, CZERO, VT, 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) +* + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy result to VT +* + CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (CWorkspace: need 2*M, prefer M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IE = 1 + ITAUQ = ITAU + ITAUP = ITAUQ + M + IWORK = ITAUP + M +* +* Zero out above L in A +* + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, + $ A( 1, 2 ), LDA ) +* +* Bidiagonalize L in A +* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) +* (RWorkspace: need M) +* + CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply right vectors bidiagonalizing L by Q in VT +* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) +* (RWorkspace: 0) +* + CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA, + $ WORK( ITAUP ), VT, LDVT, + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IRWORK = IE + M +* +* Perform bidiagonal QR iteration, computing right +* singular vectors of A in VT +* (CWorkspace: 0) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT, + $ LDVT, CDUM, 1, CDUM, 1, + $ RWORK( IRWORK ), INFO ) +* + END IF +* + ELSE IF( WNTUO ) THEN +* +* 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.GE.2*M*M+3*M ) THEN +* +* Sufficient workspace for a fast algorithm +* + IU = 1 + IF( LWORK.GE.WRKBL+2*LDA*M ) THEN +* +* WORK(IU) is LDA by M and WORK(IR) is LDA by M +* + LDWRKU = LDA + IR = IU + LDWRKU*M + LDWRKR = LDA + ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN +* +* 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 + END IF + 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) +* + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to WORK(IU), zeroing out below it +* + CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ), + $ LDWRKU ) + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, + $ WORK( IU+LDWRKU ), LDWRKU ) +* +* Generate Q in A +* (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S, + $ RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + CALL 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) +* + CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), + $ WORK( IU ), LDWRKU, WORK( IR ), + $ LDWRKR, CDUM, 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) +* + CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ), + $ LDWRKU, A, LDA, CZERO, VT, LDVT ) +* +* Copy left singular vectors of L to A +* (CWorkspace: need M*M) +* (RWorkspace: 0) +* + CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, + $ 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) +* + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (CWorkspace: need 2*M, prefer M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IE = 1 + ITAUQ = ITAU + ITAUP = ITAUQ + M + IWORK = ITAUP + M +* +* Zero out above L in A +* + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, + $ A( 1, 2 ), LDA ) +* +* Bidiagonalize L in A +* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) +* (RWorkspace: need M) +* + CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply right vectors bidiagonalizing L by Q in VT +* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) +* (RWorkspace: 0) +* + CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA, + $ WORK( ITAUP ), VT, LDVT, + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Generate left bidiagonalizing vectors of L in A +* (CWorkspace: need 3*M, prefer 2*M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT, + $ LDVT, A, LDA, CDUM, 1, + $ RWORK( IRWORK ), INFO ) +* + END IF +* + ELSE IF( WNTUAS ) THEN +* +* 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.GE.M*M+3*M ) THEN +* +* Sufficient workspace for a fast algorithm +* + IU = 1 + IF( LWORK.GE.WRKBL+LDA*M ) THEN +* +* WORK(IU) is LDA by N +* + LDWRKU = LDA + ELSE +* +* WORK(IU) is LDA by M +* + LDWRKU = M + END IF + 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) +* + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to WORK(IU), zeroing out above it +* + CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ), + $ LDWRKU ) + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, + $ WORK( IU+LDWRKU ), LDWRKU ) +* +* Generate Q in A +* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S, + $ RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, + $ 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) +* + CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate left bidiagonalizing vectors in U +* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), + $ WORK( IU ), LDWRKU, U, LDU, CDUM, 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) +* + CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ), + $ LDWRKU, A, LDA, CZERO, VT, 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) +* + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (CWorkspace: need 2*M, prefer M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to U, zeroing out above it +* + CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, + $ U( 1, 2 ), 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) +* + CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply right bidiagonalizing vectors in U by Q +* in VT +* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) +* (RWorkspace: 0) +* + CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU, + $ WORK( ITAUP ), VT, LDVT, + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Generate left bidiagonalizing vectors in U +* (CWorkspace: need 3*M, prefer 2*M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT, + $ LDVT, U, LDU, CDUM, 1, + $ RWORK( IRWORK ), INFO ) +* + END IF +* + END IF +* + ELSE IF( WNTVA ) THEN +* + IF( WNTUN ) THEN +* +* 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 +* + IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IR = 1 + IF( LWORK.GE.WRKBL+LDA*M ) THEN +* +* WORK(IR) is LDA by M +* + LDWRKR = LDA + ELSE +* +* WORK(IR) is M by M +* + LDWRKR = M + END IF + 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) +* + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Copy L to WORK(IR), zeroing out above it +* + CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), + $ LDWRKR ) + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, + $ WORK( IR+LDWRKR ), LDWRKR ) +* +* Generate Q in VT +* (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, + $ RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + IRWORK = IE + M +* +* Perform bidiagonal QR iteration, computing right +* singular vectors of L in WORK(IR) +* (CWorkspace: need M*M) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ), + $ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 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) +* + CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ), + $ LDWRKR, VT, LDVT, CZERO, A, LDA ) +* +* Copy right singular vectors of A from A to VT +* + CALL ZLACPY( 'F', M, N, A, LDA, VT, 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) +* + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (CWorkspace: need M+N, prefer M+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IE = 1 + ITAUQ = ITAU + ITAUP = ITAUQ + M + IWORK = ITAUP + M +* +* Zero out above L in A +* + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, + $ A( 1, 2 ), LDA ) +* +* Bidiagonalize L in A +* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) +* (RWorkspace: need M) +* + CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply right bidiagonalizing vectors in A by Q +* in VT +* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) +* (RWorkspace: 0) +* + CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA, + $ WORK( ITAUP ), VT, LDVT, + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IRWORK = IE + M +* +* Perform bidiagonal QR iteration, computing right +* singular vectors of A in VT +* (CWorkspace: 0) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT, + $ LDVT, CDUM, 1, CDUM, 1, + $ RWORK( IRWORK ), INFO ) +* + END IF +* + ELSE IF( WNTUO ) THEN +* +* 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 +* + IF( LWORK.GE.2*M*M+MAX( N+M, 3*M ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IU = 1 + IF( LWORK.GE.WRKBL+2*LDA*M ) THEN +* +* WORK(IU) is LDA by M and WORK(IR) is LDA by M +* + LDWRKU = LDA + IR = IU + LDWRKU*M + LDWRKR = LDA + ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN +* +* 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 + END IF + 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) +* + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (CWorkspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to WORK(IU), zeroing out above it +* + CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ), + $ LDWRKU ) + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, + $ 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) +* + CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S, + $ RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + CALL 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) +* + CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, + $ WORK( ITAUQ ), WORK( IWORK ), + $ LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), + $ WORK( IU ), LDWRKU, WORK( IR ), + $ LDWRKR, CDUM, 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) +* + CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ), + $ LDWRKU, VT, LDVT, CZERO, A, LDA ) +* +* Copy right singular vectors of A from A to VT +* + CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT ) +* +* Copy left singular vectors of A from WORK(IR) to A +* + CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, + $ 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) +* + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (CWorkspace: need M+N, prefer M+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + IE = 1 + ITAUQ = ITAU + ITAUP = ITAUQ + M + IWORK = ITAUP + M +* +* Zero out above L in A +* + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, + $ A( 1, 2 ), LDA ) +* +* Bidiagonalize L in A +* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) +* (RWorkspace: need M) +* + CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply right bidiagonalizing vectors in A by Q +* in VT +* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) +* (RWorkspace: 0) +* + CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA, + $ WORK( ITAUP ), VT, LDVT, + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Generate left bidiagonalizing vectors in A +* (CWorkspace: need 3*M, prefer 2*M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT, + $ LDVT, A, LDA, CDUM, 1, + $ RWORK( IRWORK ), INFO ) +* + END IF +* + ELSE IF( WNTUAS ) THEN +* +* 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 +* + IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN +* +* Sufficient workspace for a fast algorithm +* + IU = 1 + IF( LWORK.GE.WRKBL+LDA*M ) THEN +* +* WORK(IU) is LDA by M +* + LDWRKU = LDA + ELSE +* +* WORK(IU) is M by M +* + LDWRKU = M + END IF + 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) +* + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to WORK(IU), zeroing out above it +* + CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ), + $ LDWRKU ) + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, + $ 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) +* + CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S, + $ RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, + $ LDU ) +* +* Generate right bidiagonalizing vectors in WORK(IU) +* (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU, + $ WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, IERR ) +* +* Generate left bidiagonalizing vectors in U +* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), + $ WORK( IU ), LDWRKU, U, LDU, CDUM, 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) +* + CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ), + $ LDWRKU, VT, LDVT, CZERO, A, LDA ) +* +* Copy right singular vectors of A from A to VT +* + CALL ZLACPY( 'F', M, N, A, LDA, VT, 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) +* + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (CWorkspace: need M+N, prefer M+N*NB) +* (RWorkspace: 0) +* + CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Copy L to U, zeroing out above it +* + CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, + $ U( 1, 2 ), 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) +* + CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Multiply right bidiagonalizing vectors in U by Q +* in VT +* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) +* (RWorkspace: 0) +* + CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU, + $ WORK( ITAUP ), VT, LDVT, + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) +* +* Generate left bidiagonalizing vectors in U +* (CWorkspace: need 3*M, prefer 2*M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, 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) +* + CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT, + $ LDVT, U, LDU, CDUM, 1, + $ RWORK( IRWORK ), INFO ) +* + END IF +* + END IF +* + END IF +* + 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) +* + CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, + $ IERR ) + IF( WNTUAS ) THEN +* +* 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) +* + CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) + CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IF( WNTVAS ) THEN +* +* 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) +* + CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) + IF( WNTVA ) + $ NRVT = N + IF( WNTVS ) + $ NRVT = M + CALL ZUNGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IF( WNTUO ) THEN +* +* 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) +* + CALL ZUNGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IF( WNTVO ) THEN +* +* If right singular vectors desired in A, generate right +* bidiagonalizing vectors in A +* (CWorkspace: need 3*M, prefer 2*M+M*NB) +* (RWorkspace: 0) +* + CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, IERR ) + END IF + IRWORK = IE + M + IF( WNTUAS .OR. WNTUO ) + $ NRU = M + IF( WNTUN ) + $ NRU = 0 + IF( WNTVAS .OR. WNTVO ) + $ NCVT = N + IF( WNTVN ) + $ NCVT = 0 + IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN +* +* Perform bidiagonal QR iteration, if desired, computing +* left singular vectors in U and computing right singular +* vectors in VT +* (CWorkspace: 0) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT, + $ LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ), + $ INFO ) + ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN +* +* Perform bidiagonal QR iteration, if desired, computing +* left singular vectors in U and computing right singular +* vectors in A +* (CWorkspace: 0) +* (RWorkspace: need BDSPAC) +* + CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), A, + $ LDA, U, LDU, CDUM, 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) +* + CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT, + $ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ), + $ INFO ) + END IF +* + END IF +* + END IF +* +* Undo scaling if necessary +* + IF( ISCL.EQ.1 ) THEN + IF( ANRM.GT.BIGNUM ) + $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, + $ IERR ) + IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) + $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, + $ RWORK( IE ), MINMN, IERR ) + IF( ANRM.LT.SMLNUM ) + $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, + $ IERR ) + IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) + $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, + $ RWORK( IE ), MINMN, IERR ) + END IF +* +* Return optimal workspace in WORK(1) +* + WORK( 1 ) = MAXWRK +* + RETURN +* +* End of ZGESVD +* + END diff --git a/2.3-1/src/fortran/lapack/zgetc2.f b/2.3-1/src/fortran/lapack/zgetc2.f new file mode 100644 index 00000000..35ac376c --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgetc2.f @@ -0,0 +1,145 @@ + SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), JPIV( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IP, IPV, J, JP, JPV + DOUBLE PRECISION BIGNUM, EPS, SMIN, SMLNUM, XMAX +* .. +* .. External Subroutines .. + EXTERNAL ZGERU, ZSWAP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DCMPLX, MAX +* .. +* .. Executable Statements .. +* +* Set constants to control overflow +* + INFO = 0 + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* +* Factorize A using complete pivoting. +* Set pivots less than SMIN to SMIN +* + DO 40 I = 1, N - 1 +* +* Find max element in matrix A +* + XMAX = ZERO + DO 20 IP = I, N + DO 10 JP = I, N + IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN + XMAX = ABS( A( IP, JP ) ) + IPV = IP + JPV = JP + END IF + 10 CONTINUE + 20 CONTINUE + IF( I.EQ.1 ) + $ SMIN = MAX( EPS*XMAX, SMLNUM ) +* +* Swap rows +* + IF( IPV.NE.I ) + $ CALL ZSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA ) + IPIV( I ) = IPV +* +* Swap columns +* + IF( JPV.NE.I ) + $ CALL ZSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 ) + JPIV( I ) = JPV +* +* Check for singularity +* + IF( ABS( A( I, I ) ).LT.SMIN ) THEN + INFO = I + A( I, I ) = DCMPLX( SMIN, ZERO ) + END IF + DO 30 J = I + 1, N + A( J, I ) = A( J, I ) / A( I, I ) + 30 CONTINUE + CALL ZGERU( N-I, N-I, -DCMPLX( ONE ), A( I+1, I ), 1, + $ A( I, I+1 ), LDA, A( I+1, I+1 ), LDA ) + 40 CONTINUE +* + IF( ABS( A( N, N ) ).LT.SMIN ) THEN + INFO = N + A( N, N ) = DCMPLX( SMIN, ZERO ) + END IF + RETURN +* +* End of ZGETC2 +* + END diff --git a/2.3-1/src/fortran/lapack/zgetf2.f b/2.3-1/src/fortran/lapack/zgetf2.f new file mode 100644 index 00000000..a2dc1834 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgetf2.f @@ -0,0 +1,148 @@ + SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* 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 .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION SFMIN + INTEGER I, J, JP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER IZAMAX + EXTERNAL DLAMCH, IZAMAX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGETF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Compute machine safe minimum +* + SFMIN = DLAMCH('S') +* + DO 10 J = 1, MIN( M, N ) +* +* Find pivot and test for singularity. +* + JP = J - 1 + IZAMAX( M-J+1, A( J, J ), 1 ) + IPIV( J ) = JP + IF( A( JP, J ).NE.ZERO ) THEN +* +* Apply the interchange to columns 1:N. +* + IF( JP.NE.J ) + $ CALL ZSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) +* +* Compute elements J+1:M of J-th column. +* + IF( J.LT.M ) THEN + IF( ABS(A( J, J )) .GE. SFMIN ) THEN + CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) + ELSE + DO 20 I = 1, M-J + A( J+I, J ) = A( J+I, J ) / A( J, J ) + 20 CONTINUE + END IF + END IF +* + ELSE IF( INFO.EQ.0 ) THEN +* + INFO = J + END IF +* + IF( J.LT.MIN( M, N ) ) THEN +* +* Update trailing submatrix. +* + CALL ZGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), + $ LDA, A( J+1, J+1 ), LDA ) + END IF + 10 CONTINUE + RETURN +* +* End of ZGETF2 +* + END diff --git a/2.3-1/src/fortran/lapack/zgetrf.f b/2.3-1/src/fortran/lapack/zgetrf.f new file mode 100644 index 00000000..9c7bfbbf --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgetrf.f @@ -0,0 +1,159 @@ + SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* 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 .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, IINFO, J, JB, NB +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGEMM, ZGETF2, ZLASWP, ZTRSM +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGETRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'ZGETRF', ' ', M, N, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN +* +* Use unblocked code. +* + CALL ZGETF2( M, N, A, LDA, IPIV, INFO ) + ELSE +* +* Use blocked code. +* + DO 20 J = 1, MIN( M, N ), NB + JB = MIN( MIN( M, N )-J+1, NB ) +* +* Factor diagonal and subdiagonal blocks and test for exact +* singularity. +* + CALL ZGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) +* +* Adjust INFO and the pivot indices. +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + J - 1 + DO 10 I = J, MIN( M, J+JB-1 ) + IPIV( I ) = J - 1 + IPIV( I ) + 10 CONTINUE +* +* Apply interchanges to columns 1:J-1. +* + CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) +* + IF( J+JB.LE.N ) THEN +* +* Apply interchanges to columns J+JB:N. +* + CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, + $ IPIV, 1 ) +* +* Compute block row of U. +* + CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, + $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), + $ LDA ) + IF( J+JB.LE.M ) THEN +* +* Update trailing submatrix. +* + CALL ZGEMM( 'No transpose', 'No transpose', M-J-JB+1, + $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, + $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), + $ LDA ) + END IF + END IF + 20 CONTINUE + END IF + RETURN +* +* End of ZGETRF +* + END diff --git a/2.3-1/src/fortran/lapack/zgetri.f b/2.3-1/src/fortran/lapack/zgetri.f new file mode 100644 index 00000000..685518e6 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgetri.f @@ -0,0 +1,193 @@ + SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB, + $ NBMIN, NN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGEMM, ZGEMV, ZSWAP, ZTRSM, ZTRTRI +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NB = ILAENV( 1, 'ZGETRI', ' ', N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -3 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGETRI', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Form inv(U). If INFO > 0 from ZTRTRI, then U is singular, +* and the inverse is not computed. +* + CALL ZTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO ) + IF( INFO.GT.0 ) + $ RETURN +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = MAX( LDWORK*NB, 1 ) + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'ZGETRI', ' ', N, -1, -1, -1 ) ) + END IF + ELSE + IWS = N + END IF +* +* Solve the equation inv(A)*L = inv(U) for inv(A). +* + IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN +* +* Use unblocked code. +* + DO 20 J = N, 1, -1 +* +* Copy current column of L to WORK and replace with zeros. +* + DO 10 I = J + 1, N + WORK( I ) = A( I, J ) + A( I, J ) = ZERO + 10 CONTINUE +* +* Compute current column of inv(A). +* + IF( J.LT.N ) + $ CALL ZGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ), + $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 ) + 20 CONTINUE + ELSE +* +* Use blocked code. +* + NN = ( ( N-1 ) / NB )*NB + 1 + DO 50 J = NN, 1, -NB + JB = MIN( NB, N-J+1 ) +* +* Copy current block column of L to WORK and replace with +* zeros. +* + DO 40 JJ = J, J + JB - 1 + DO 30 I = JJ + 1, N + WORK( I+( JJ-J )*LDWORK ) = A( I, JJ ) + A( I, JJ ) = ZERO + 30 CONTINUE + 40 CONTINUE +* +* Compute current block column of inv(A). +* + IF( J+JB.LE.N ) + $ CALL ZGEMM( 'No transpose', 'No transpose', N, JB, + $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA, + $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA ) + CALL ZTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB, + $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA ) + 50 CONTINUE + END IF +* +* Apply column interchanges. +* + DO 60 J = N - 1, 1, -1 + JP = IPIV( J ) + IF( JP.NE.J ) + $ CALL ZSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) + 60 CONTINUE +* + WORK( 1 ) = IWS + RETURN +* +* End of ZGETRI +* + END diff --git a/2.3-1/src/fortran/lapack/zgetrs.f b/2.3-1/src/fortran/lapack/zgetrs.f new file mode 100644 index 00000000..e32549cd --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgetrs.f @@ -0,0 +1,149 @@ + SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* 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 .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLASWP, ZTRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGETRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( NOTRAN ) THEN +* +* Solve A * X = B. +* +* Apply row interchanges to the right hand sides. +* + CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) +* +* Solve L*X = B, overwriting B with X. +* + CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve U*X = B, overwriting B with X. +* + CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, A, LDA, B, LDB ) + ELSE +* +* Solve A**T * X = B or A**H * X = B. +* +* Solve U'*X = B, overwriting B with X. +* + CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, + $ A, LDA, B, LDB ) +* +* Solve L'*X = B, overwriting B with X. +* + CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A, + $ LDA, B, LDB ) +* +* Apply row interchanges to the solution vectors. +* + CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) + END IF +* + RETURN +* +* End of ZGETRS +* + END diff --git a/2.3-1/src/fortran/lapack/zggbak.f b/2.3-1/src/fortran/lapack/zggbak.f new file mode 100644 index 00000000..ad6dd032 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zggbak.f @@ -0,0 +1,220 @@ + SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, + $ LDV, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOB, SIDE + INTEGER IHI, ILO, INFO, LDV, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION LSCALE( * ), RSCALE( * ) + COMPLEX*16 V( LDV, * ) +* .. +* +* 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 .. + LOGICAL LEFTV, RIGHTV + INTEGER I, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZDSCAL, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + RIGHTV = LSAME( SIDE, 'R' ) + LEFTV = LSAME( SIDE, 'L' ) +* + INFO = 0 + IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. + $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN + INFO = -1 + ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ILO.LT.1 ) THEN + INFO = -4 + ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN + INFO = -4 + ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) ) + $ THEN + INFO = -5 + ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -8 + ELSE IF( LDV.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGGBAK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + IF( M.EQ.0 ) + $ RETURN + IF( LSAME( JOB, 'N' ) ) + $ RETURN +* + IF( ILO.EQ.IHI ) + $ GO TO 30 +* +* Backward balance +* + IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN +* +* Backward transformation on right eigenvectors +* + IF( RIGHTV ) THEN + DO 10 I = ILO, IHI + CALL ZDSCAL( M, RSCALE( I ), V( I, 1 ), LDV ) + 10 CONTINUE + END IF +* +* Backward transformation on left eigenvectors +* + IF( LEFTV ) THEN + DO 20 I = ILO, IHI + CALL ZDSCAL( M, LSCALE( I ), V( I, 1 ), LDV ) + 20 CONTINUE + END IF + END IF +* +* Backward permutation +* + 30 CONTINUE + IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN +* +* Backward permutation on right eigenvectors +* + IF( RIGHTV ) THEN + IF( ILO.EQ.1 ) + $ GO TO 50 + DO 40 I = ILO - 1, 1, -1 + K = RSCALE( I ) + IF( K.EQ.I ) + $ GO TO 40 + CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 40 CONTINUE +* + 50 CONTINUE + IF( IHI.EQ.N ) + $ GO TO 70 + DO 60 I = IHI + 1, N + K = RSCALE( I ) + IF( K.EQ.I ) + $ GO TO 60 + CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 60 CONTINUE + END IF +* +* Backward permutation on left eigenvectors +* + 70 CONTINUE + IF( LEFTV ) THEN + IF( ILO.EQ.1 ) + $ GO TO 90 + DO 80 I = ILO - 1, 1, -1 + K = LSCALE( I ) + IF( K.EQ.I ) + $ GO TO 80 + CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 80 CONTINUE +* + 90 CONTINUE + IF( IHI.EQ.N ) + $ GO TO 110 + DO 100 I = IHI + 1, N + K = LSCALE( I ) + IF( K.EQ.I ) + $ GO TO 100 + CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 100 CONTINUE + END IF + END IF +* + 110 CONTINUE +* + RETURN +* +* End of ZGGBAK +* + END diff --git a/2.3-1/src/fortran/lapack/zggbal.f b/2.3-1/src/fortran/lapack/zggbal.f new file mode 100644 index 00000000..b75ae456 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zggbal.f @@ -0,0 +1,482 @@ + SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, + $ RSCALE, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOB + INTEGER IHI, ILO, INFO, LDA, LDB, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION LSCALE( * ), RSCALE( * ), WORK( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION THREE, SCLFAC + PARAMETER ( THREE = 3.0D+0, SCLFAC = 1.0D+1 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1, + $ K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN, + $ M, NR, NRP2 + DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, + $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, + $ SFMIN, SUM, T, TA, TB, TC + COMPLEX*16 CDUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL LSAME, IZAMAX, DDOT, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DSCAL, XERBLA, ZDSCAL, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG, INT, LOG10, MAX, MIN, SIGN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. + $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGGBAL', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + ILO = 1 + IHI = N + RETURN + END IF +* + IF( N.EQ.1 ) THEN + ILO = 1 + IHI = N + LSCALE( 1 ) = ONE + RSCALE( 1 ) = ONE + RETURN + END IF +* + IF( LSAME( JOB, 'N' ) ) THEN + ILO = 1 + IHI = N + DO 10 I = 1, N + LSCALE( I ) = ONE + RSCALE( I ) = ONE + 10 CONTINUE + RETURN + END IF +* + K = 1 + L = N + IF( LSAME( JOB, 'S' ) ) + $ GO TO 190 +* + GO TO 30 +* +* Permute the matrices A and B to isolate the eigenvalues. +* +* Find row with one nonzero in columns 1 through L +* + 20 CONTINUE + L = LM1 + IF( L.NE.1 ) + $ GO TO 30 +* + RSCALE( 1 ) = 1 + LSCALE( 1 ) = 1 + GO TO 190 +* + 30 CONTINUE + LM1 = L - 1 + DO 80 I = L, 1, -1 + DO 40 J = 1, LM1 + JP1 = J + 1 + IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) + $ GO TO 50 + 40 CONTINUE + J = L + GO TO 70 +* + 50 CONTINUE + DO 60 J = JP1, L + IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) + $ GO TO 80 + 60 CONTINUE + J = JP1 - 1 +* + 70 CONTINUE + M = L + IFLOW = 1 + GO TO 160 + 80 CONTINUE + GO TO 100 +* +* Find column with one nonzero in rows K through N +* + 90 CONTINUE + K = K + 1 +* + 100 CONTINUE + DO 150 J = K, L + DO 110 I = K, LM1 + IP1 = I + 1 + IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) + $ GO TO 120 + 110 CONTINUE + I = L + GO TO 140 + 120 CONTINUE + DO 130 I = IP1, L + IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) + $ GO TO 150 + 130 CONTINUE + I = IP1 - 1 + 140 CONTINUE + M = K + IFLOW = 2 + GO TO 160 + 150 CONTINUE + GO TO 190 +* +* Permute rows M and I +* + 160 CONTINUE + LSCALE( M ) = I + IF( I.EQ.M ) + $ GO TO 170 + CALL ZSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA ) + CALL ZSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB ) +* +* Permute columns M and J +* + 170 CONTINUE + RSCALE( M ) = J + IF( J.EQ.M ) + $ GO TO 180 + CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) + CALL ZSWAP( L, B( 1, J ), 1, B( 1, M ), 1 ) +* + 180 CONTINUE + GO TO ( 20, 90 )IFLOW +* + 190 CONTINUE + ILO = K + IHI = L +* + IF( LSAME( JOB, 'P' ) ) THEN + DO 195 I = ILO, IHI + LSCALE( I ) = ONE + RSCALE( I ) = ONE + 195 CONTINUE + RETURN + END IF +* + IF( ILO.EQ.IHI ) + $ RETURN +* +* Balance the submatrix in rows ILO to IHI. +* + NR = IHI - ILO + 1 + DO 200 I = ILO, IHI + RSCALE( I ) = ZERO + LSCALE( I ) = ZERO +* + WORK( I ) = ZERO + WORK( I+N ) = ZERO + WORK( I+2*N ) = ZERO + WORK( I+3*N ) = ZERO + WORK( I+4*N ) = ZERO + WORK( I+5*N ) = ZERO + 200 CONTINUE +* +* Compute right side vector in resulting linear equations +* + BASL = LOG10( SCLFAC ) + DO 240 I = ILO, IHI + DO 230 J = ILO, IHI + IF( A( I, J ).EQ.CZERO ) THEN + TA = ZERO + GO TO 210 + END IF + TA = LOG10( CABS1( A( I, J ) ) ) / BASL +* + 210 CONTINUE + IF( B( I, J ).EQ.CZERO ) THEN + TB = ZERO + GO TO 220 + END IF + TB = LOG10( CABS1( B( I, J ) ) ) / BASL +* + 220 CONTINUE + WORK( I+4*N ) = WORK( I+4*N ) - TA - TB + WORK( J+5*N ) = WORK( J+5*N ) - TA - TB + 230 CONTINUE + 240 CONTINUE +* + COEF = ONE / DBLE( 2*NR ) + COEF2 = COEF*COEF + COEF5 = HALF*COEF2 + NRP2 = NR + 2 + BETA = ZERO + IT = 1 +* +* Start generalized conjugate gradient iteration +* + 250 CONTINUE +* + GAMMA = DDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) + + $ DDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 ) +* + EW = ZERO + EWC = ZERO + DO 260 I = ILO, IHI + EW = EW + WORK( I+4*N ) + EWC = EWC + WORK( I+5*N ) + 260 CONTINUE +* + GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2 + IF( GAMMA.EQ.ZERO ) + $ GO TO 350 + IF( IT.NE.1 ) + $ BETA = GAMMA / PGAMMA + T = COEF5*( EWC-THREE*EW ) + TC = COEF5*( EW-THREE*EWC ) +* + CALL DSCAL( NR, BETA, WORK( ILO ), 1 ) + CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 ) +* + CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 ) + CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 ) +* + DO 270 I = ILO, IHI + WORK( I ) = WORK( I ) + TC + WORK( I+N ) = WORK( I+N ) + T + 270 CONTINUE +* +* Apply matrix to vector +* + DO 300 I = ILO, IHI + KOUNT = 0 + SUM = ZERO + DO 290 J = ILO, IHI + IF( A( I, J ).EQ.CZERO ) + $ GO TO 280 + KOUNT = KOUNT + 1 + SUM = SUM + WORK( J ) + 280 CONTINUE + IF( B( I, J ).EQ.CZERO ) + $ GO TO 290 + KOUNT = KOUNT + 1 + SUM = SUM + WORK( J ) + 290 CONTINUE + WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM + 300 CONTINUE +* + DO 330 J = ILO, IHI + KOUNT = 0 + SUM = ZERO + DO 320 I = ILO, IHI + IF( A( I, J ).EQ.CZERO ) + $ GO TO 310 + KOUNT = KOUNT + 1 + SUM = SUM + WORK( I+N ) + 310 CONTINUE + IF( B( I, J ).EQ.CZERO ) + $ GO TO 320 + KOUNT = KOUNT + 1 + SUM = SUM + WORK( I+N ) + 320 CONTINUE + WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM + 330 CONTINUE +* + SUM = DDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) + + $ DDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 ) + ALPHA = GAMMA / SUM +* +* Determine correction to current iteration +* + CMAX = ZERO + DO 340 I = ILO, IHI + COR = ALPHA*WORK( I+N ) + IF( ABS( COR ).GT.CMAX ) + $ CMAX = ABS( COR ) + LSCALE( I ) = LSCALE( I ) + COR + COR = ALPHA*WORK( I ) + IF( ABS( COR ).GT.CMAX ) + $ CMAX = ABS( COR ) + RSCALE( I ) = RSCALE( I ) + COR + 340 CONTINUE + IF( CMAX.LT.HALF ) + $ GO TO 350 +* + CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 ) + CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 ) +* + PGAMMA = GAMMA + IT = IT + 1 + IF( IT.LE.NRP2 ) + $ GO TO 250 +* +* End generalized conjugate gradient iteration +* + 350 CONTINUE + SFMIN = DLAMCH( 'S' ) + SFMAX = ONE / SFMIN + LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE ) + LSFMAX = INT( LOG10( SFMAX ) / BASL ) + DO 360 I = ILO, IHI + IRAB = IZAMAX( N-ILO+1, A( I, ILO ), LDA ) + RAB = ABS( A( I, IRAB+ILO-1 ) ) + IRAB = IZAMAX( N-ILO+1, B( I, ILO ), LDB ) + RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) + LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) + IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) + IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) + LSCALE( I ) = SCLFAC**IR + ICAB = IZAMAX( IHI, A( 1, I ), 1 ) + CAB = ABS( A( ICAB, I ) ) + ICAB = IZAMAX( IHI, B( 1, I ), 1 ) + CAB = MAX( CAB, ABS( B( ICAB, I ) ) ) + LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE ) + JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) ) + JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) + RSCALE( I ) = SCLFAC**JC + 360 CONTINUE +* +* Row scaling of matrices A and B +* + DO 370 I = ILO, IHI + CALL ZDSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA ) + CALL ZDSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB ) + 370 CONTINUE +* +* Column scaling of matrices A and B +* + DO 380 J = ILO, IHI + CALL ZDSCAL( IHI, RSCALE( J ), A( 1, J ), 1 ) + CALL ZDSCAL( IHI, RSCALE( J ), B( 1, J ), 1 ) + 380 CONTINUE +* + RETURN +* +* End of ZGGBAL +* + END diff --git a/2.3-1/src/fortran/lapack/zgges.f b/2.3-1/src/fortran/lapack/zgges.f new file mode 100644 index 00000000..c1499003 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgges.f @@ -0,0 +1,477 @@ + SUBROUTINE ZGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, + $ SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, + $ LWORK, RWORK, BWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBVSL, JOBVSR, SORT + INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), + $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), + $ WORK( * ) +* .. +* .. Function Arguments .. + LOGICAL SELCTG + EXTERNAL SELCTG +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), + $ CONE = ( 1.0D0, 0.0D0 ) ) +* .. +* .. Local Scalars .. + LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, + $ LQUERY, WANTST + INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, + $ ILO, IRIGHT, IROWS, IRWRK, ITAU, IWRK, LWKMIN, + $ LWKOPT + DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL, + $ PVSR, SMLNUM +* .. +* .. Local Arrays .. + INTEGER IDUM( 1 ) + DOUBLE PRECISION DIF( 2 ) +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD, + $ ZHGEQZ, ZLACPY, ZLASCL, ZLASET, ZTGSEN, ZUNGQR, + $ ZUNMQR +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode the input arguments +* + IF( LSAME( JOBVSL, 'N' ) ) THEN + IJOBVL = 1 + ILVSL = .FALSE. + ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN + IJOBVL = 2 + ILVSL = .TRUE. + ELSE + IJOBVL = -1 + ILVSL = .FALSE. + END IF +* + IF( LSAME( JOBVSR, 'N' ) ) THEN + IJOBVR = 1 + ILVSR = .FALSE. + ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN + IJOBVR = 2 + ILVSR = .TRUE. + ELSE + IJOBVR = -1 + ILVSR = .FALSE. + END IF +* + WANTST = LSAME( SORT, 'S' ) +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( IJOBVL.LE.0 ) THEN + INFO = -1 + ELSE IF( IJOBVR.LE.0 ) THEN + INFO = -2 + ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN + INFO = -14 + ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN + INFO = -16 + END IF +* +* 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.EQ.0 ) THEN + LWKMIN = MAX( 1, 2*N ) + LWKOPT = MAX( 1, N + N*ILAENV( 1, 'ZGEQRF', ' ', N, 1, N, 0 ) ) + LWKOPT = MAX( LWKOPT, N + + $ N*ILAENV( 1, 'ZUNMQR', ' ', N, 1, N, -1 ) ) + IF( ILVSL ) THEN + LWKOPT = MAX( LWKOPT, N + + $ N*ILAENV( 1, 'ZUNGQR', ' ', N, 1, N, -1 ) ) + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) + $ INFO = -18 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGGES ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + SDIM = 0 + RETURN + END IF +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = ZLANGE( 'M', N, N, A, LDA, RWORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF +* + IF( ILASCL ) + $ CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) +* +* Scale B if max element outside range [SMLNUM,BIGNUM] +* + BNRM = ZLANGE( 'M', N, N, B, LDB, RWORK ) + ILBSCL = .FALSE. + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + BNRMTO = SMLNUM + ILBSCL = .TRUE. + ELSE IF( BNRM.GT.BIGNUM ) THEN + BNRMTO = BIGNUM + ILBSCL = .TRUE. + END IF +* + IF( ILBSCL ) + $ CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) +* +* Permute the matrix to make it more nearly triangular +* (Real Workspace: need 6*N) +* + ILEFT = 1 + IRIGHT = N + 1 + IRWRK = IRIGHT + N + CALL ZGGBAL( 'P', N, A, LDA, B, 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 + CALL ZGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) +* +* Apply the orthogonal transformation to matrix A +* (Complex Workspace: need N, prefer N*NB) +* + CALL ZUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, + $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), + $ LWORK+1-IWRK, IERR ) +* +* Initialize VSL +* (Complex Workspace: need N, prefer N*NB) +* + IF( ILVSL ) THEN + CALL ZLASET( 'Full', N, N, CZERO, CONE, VSL, LDVSL ) + IF( IROWS.GT.1 ) THEN + CALL ZLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, + $ VSL( ILO+1, ILO ), LDVSL ) + END IF + CALL ZUNGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, + $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Initialize VSR +* + IF( ILVSR ) + $ CALL ZLASET( 'Full', N, N, CZERO, CONE, VSR, LDVSR ) +* +* Reduce to generalized Hessenberg form +* (Workspace: none needed) +* + CALL ZGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, + $ LDVSL, VSR, LDVSR, IERR ) +* + SDIM = 0 +* +* Perform QZ algorithm, computing Schur vectors if desired +* (Complex Workspace: need N) +* (Real Workspace: need N) +* + IWRK = ITAU + CALL ZHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, + $ ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK( IWRK ), + $ LWORK+1-IWRK, RWORK( IRWRK ), IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.GT.0 .AND. IERR.LE.N ) THEN + INFO = IERR + ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN + INFO = IERR - N + ELSE + INFO = N + 1 + END IF + GO TO 30 + END IF +* +* Sort eigenvalues ALPHA/BETA if desired +* (Workspace: none needed) +* + IF( WANTST ) THEN +* +* Undo scaling on eigenvalues before selecting +* + IF( ILASCL ) + $ CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, 1, ALPHA, N, IERR ) + IF( ILBSCL ) + $ CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, 1, BETA, N, IERR ) +* +* Select eigenvalues +* + DO 10 I = 1, N + BWORK( I ) = SELCTG( ALPHA( I ), BETA( I ) ) + 10 CONTINUE +* + CALL ZTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHA, + $ BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL, PVSR, + $ DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, IERR ) + IF( IERR.EQ.1 ) + $ INFO = N + 3 +* + END IF +* +* Apply back-permutation to VSL and VSR +* (Workspace: none needed) +* + IF( ILVSL ) + $ CALL ZGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ), + $ RWORK( IRIGHT ), N, VSL, LDVSL, IERR ) + IF( ILVSR ) + $ CALL ZGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ), + $ RWORK( IRIGHT ), N, VSR, LDVSR, IERR ) +* +* Undo scaling +* + IF( ILASCL ) THEN + CALL ZLASCL( 'U', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR ) + CALL ZLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR ) + END IF +* + IF( ILBSCL ) THEN + CALL ZLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR ) + CALL ZLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) + END IF +* + IF( WANTST ) THEN +* +* Check if reordering is correct +* + LASTSL = .TRUE. + SDIM = 0 + DO 20 I = 1, N + CURSL = SELCTG( ALPHA( I ), BETA( I ) ) + IF( CURSL ) + $ SDIM = SDIM + 1 + IF( CURSL .AND. .NOT.LASTSL ) + $ INFO = N + 2 + LASTSL = CURSL + 20 CONTINUE +* + END IF +* + 30 CONTINUE +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of ZGGES +* + END diff --git a/2.3-1/src/fortran/lapack/zggev.f b/2.3-1/src/fortran/lapack/zggev.f new file mode 100644 index 00000000..94fb3dc2 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zggev.f @@ -0,0 +1,454 @@ + SUBROUTINE ZGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, + $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBVL, JOBVR + INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), + $ BETA( * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), + $ CONE = ( 1.0D0, 0.0D0 ) ) +* .. +* .. Local Scalars .. + LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY + CHARACTER CHTEMP + INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO, + $ IN, IRIGHT, IROWS, IRWRK, ITAU, IWRK, JC, JR, + $ LWKMIN, LWKOPT + DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, + $ SMLNUM, TEMP + COMPLEX*16 X +* .. +* .. Local Arrays .. + LOGICAL LDUMMA( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD, + $ ZHGEQZ, ZLACPY, ZLASCL, ZLASET, ZTGEVC, ZUNGQR, + $ ZUNMQR +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG, MAX, SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION ABS1 +* .. +* .. Statement Function definitions .. + ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) ) +* .. +* .. Executable Statements .. +* +* Decode the input arguments +* + IF( LSAME( JOBVL, 'N' ) ) THEN + IJOBVL = 1 + ILVL = .FALSE. + ELSE IF( LSAME( JOBVL, 'V' ) ) THEN + IJOBVL = 2 + ILVL = .TRUE. + ELSE + IJOBVL = -1 + ILVL = .FALSE. + END IF +* + IF( LSAME( JOBVR, 'N' ) ) THEN + IJOBVR = 1 + ILVR = .FALSE. + ELSE IF( LSAME( JOBVR, 'V' ) ) THEN + IJOBVR = 2 + ILVR = .TRUE. + ELSE + IJOBVR = -1 + ILVR = .FALSE. + END IF + ILV = ILVL .OR. ILVR +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( IJOBVL.LE.0 ) THEN + INFO = -1 + ELSE IF( IJOBVR.LE.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN + INFO = -11 + ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN + INFO = -13 + END IF +* +* 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.EQ.0 ) THEN + LWKMIN = MAX( 1, 2*N ) + LWKOPT = MAX( 1, N + N*ILAENV( 1, 'ZGEQRF', ' ', N, 1, N, 0 ) ) + LWKOPT = MAX( LWKOPT, N + + $ N*ILAENV( 1, 'ZUNMQR', ' ', N, 1, N, 0 ) ) + IF( ILVL ) THEN + LWKOPT = MAX( LWKOPT, N + + $ N*ILAENV( 1, 'ZUNGQR', ' ', N, 1, N, -1 ) ) + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) + $ INFO = -15 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGGEV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Get machine constants +* + EPS = DLAMCH( 'E' )*DLAMCH( 'B' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = ZLANGE( 'M', N, N, A, LDA, RWORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF + IF( ILASCL ) + $ CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) +* +* Scale B if max element outside range [SMLNUM,BIGNUM] +* + BNRM = ZLANGE( 'M', N, N, B, LDB, RWORK ) + ILBSCL = .FALSE. + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + BNRMTO = SMLNUM + ILBSCL = .TRUE. + ELSE IF( BNRM.GT.BIGNUM ) THEN + BNRMTO = BIGNUM + ILBSCL = .TRUE. + END IF + IF( ILBSCL ) + $ CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, 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 + CALL ZGGBAL( 'P', N, A, LDA, B, 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 ) THEN + ICOLS = N + 1 - ILO + ELSE + ICOLS = IROWS + END IF + ITAU = 1 + IWRK = ITAU + IROWS + CALL ZGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) +* +* Apply the orthogonal transformation to matrix A +* (Complex Workspace: need N, prefer N*NB) +* + CALL ZUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, + $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), + $ LWORK+1-IWRK, IERR ) +* +* Initialize VL +* (Complex Workspace: need N, prefer N*NB) +* + IF( ILVL ) THEN + CALL ZLASET( 'Full', N, N, CZERO, CONE, VL, LDVL ) + IF( IROWS.GT.1 ) THEN + CALL ZLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, + $ VL( ILO+1, ILO ), LDVL ) + END IF + CALL ZUNGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL, + $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Initialize VR +* + IF( ILVR ) + $ CALL ZLASET( 'Full', N, N, CZERO, CONE, VR, LDVR ) +* +* Reduce to generalized Hessenberg form +* + IF( ILV ) THEN +* +* Eigenvectors requested -- work on whole matrix. +* + CALL ZGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL, + $ LDVL, VR, LDVR, IERR ) + ELSE + CALL ZGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA, + $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR ) + END IF +* +* 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 ) THEN + CHTEMP = 'S' + ELSE + CHTEMP = 'E' + END IF + CALL ZHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, + $ ALPHA, BETA, VL, LDVL, VR, LDVR, WORK( IWRK ), + $ LWORK+1-IWRK, RWORK( IRWRK ), IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.GT.0 .AND. IERR.LE.N ) THEN + INFO = IERR + ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN + INFO = IERR - N + ELSE + INFO = N + 1 + END IF + GO TO 70 + END IF +* +* Compute Eigenvectors +* (Real Workspace: need 2*N) +* (Complex Workspace: need 2*N) +* + IF( ILV ) THEN + IF( ILVL ) THEN + IF( ILVR ) THEN + CHTEMP = 'B' + ELSE + CHTEMP = 'L' + END IF + ELSE + CHTEMP = 'R' + END IF +* + CALL ZTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL, + $ VR, LDVR, N, IN, WORK( IWRK ), RWORK( IRWRK ), + $ IERR ) + IF( IERR.NE.0 ) THEN + INFO = N + 2 + GO TO 70 + END IF +* +* Undo balancing on VL and VR and normalization +* (Workspace: none needed) +* + IF( ILVL ) THEN + CALL ZGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ), + $ RWORK( IRIGHT ), N, VL, LDVL, IERR ) + DO 30 JC = 1, N + TEMP = ZERO + DO 10 JR = 1, N + TEMP = MAX( TEMP, ABS1( VL( JR, JC ) ) ) + 10 CONTINUE + IF( TEMP.LT.SMLNUM ) + $ GO TO 30 + TEMP = ONE / TEMP + DO 20 JR = 1, N + VL( JR, JC ) = VL( JR, JC )*TEMP + 20 CONTINUE + 30 CONTINUE + END IF + IF( ILVR ) THEN + CALL ZGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ), + $ RWORK( IRIGHT ), N, VR, LDVR, IERR ) + DO 60 JC = 1, N + TEMP = ZERO + DO 40 JR = 1, N + TEMP = MAX( TEMP, ABS1( VR( JR, JC ) ) ) + 40 CONTINUE + IF( TEMP.LT.SMLNUM ) + $ GO TO 60 + TEMP = ONE / TEMP + DO 50 JR = 1, N + VR( JR, JC ) = VR( JR, JC )*TEMP + 50 CONTINUE + 60 CONTINUE + END IF + END IF +* +* Undo scaling if necessary +* + IF( ILASCL ) + $ CALL ZLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR ) +* + IF( ILBSCL ) + $ CALL ZLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) +* + 70 CONTINUE + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of ZGGEV +* + END diff --git a/2.3-1/src/fortran/lapack/zgghrd.f b/2.3-1/src/fortran/lapack/zgghrd.f new file mode 100644 index 00000000..652c09d7 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zgghrd.f @@ -0,0 +1,264 @@ + SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, + $ LDQ, Z, LDZ, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ + INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), + $ Z( LDZ, * ) +* .. +* +* 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 .. + COMPLEX*16 CONE, CZERO + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), + $ CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL ILQ, ILZ + INTEGER ICOMPQ, ICOMPZ, JCOL, JROW + DOUBLE PRECISION C + COMPLEX*16 CTEMP, S +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARTG, ZLASET, ZROT +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Decode COMPQ +* + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'V' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +* +* Decode COMPZ +* + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'V' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF +* +* Test the input parameters. +* + INFO = 0 + IF( ICOMPQ.LE.0 ) THEN + INFO = -1 + ELSE IF( ICOMPZ.LE.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ILO.LT.1 ) THEN + INFO = -4 + ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN + INFO = -11 + ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGGHRD', -INFO ) + RETURN + END IF +* +* Initialize Q and Z if desired. +* + IF( ICOMPQ.EQ.3 ) + $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ ) + IF( ICOMPZ.EQ.3 ) + $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* +* Zero out lower triangle of B +* + DO 20 JCOL = 1, N - 1 + DO 10 JROW = JCOL + 1, N + B( JROW, JCOL ) = CZERO + 10 CONTINUE + 20 CONTINUE +* +* Reduce A and B +* + DO 40 JCOL = ILO, IHI - 2 +* + DO 30 JROW = IHI, JCOL + 2, -1 +* +* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) +* + CTEMP = A( JROW-1, JCOL ) + CALL ZLARTG( CTEMP, A( JROW, JCOL ), C, S, + $ A( JROW-1, JCOL ) ) + A( JROW, JCOL ) = CZERO + CALL ZROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA, + $ A( JROW, JCOL+1 ), LDA, C, S ) + CALL ZROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB, + $ B( JROW, JROW-1 ), LDB, C, S ) + IF( ILQ ) + $ CALL ZROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, + $ DCONJG( S ) ) +* +* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) +* + CTEMP = B( JROW, JROW ) + CALL ZLARTG( CTEMP, B( JROW, JROW-1 ), C, S, + $ B( JROW, JROW ) ) + B( JROW, JROW-1 ) = CZERO + CALL ZROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S ) + CALL ZROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C, + $ S ) + IF( ILZ ) + $ CALL ZROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S ) + 30 CONTINUE + 40 CONTINUE +* + RETURN +* +* End of ZGGHRD +* + END diff --git a/2.3-1/src/fortran/lapack/zheev.f b/2.3-1/src/fortran/lapack/zheev.f new file mode 100644 index 00000000..324d1612 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zheev.f @@ -0,0 +1,218 @@ + SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, + $ INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION RWORK( * ), W( * ) + COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, + $ LLWORK, LWKOPT, NB + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANHE + EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSTERF, XERBLA, ZHETRD, ZLASCL, ZSTEQR, + $ ZUNGTR +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( 1, ( NB+1 )*N ) + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) + $ INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHEEV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + RETURN + END IF +* + IF( N.EQ.1 ) THEN + W( 1 ) = A( 1, 1 ) + WORK( 1 ) = 1 + IF( WANTZ ) + $ A( 1, 1 ) = CONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) + $ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) +* +* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. +* + INDE = 1 + INDTAU = 1 + INDWRK = INDTAU + N + LLWORK = LWORK - INDWRK + 1 + CALL ZHETRD( UPLO, N, A, LDA, W, 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( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, RWORK( INDE ), INFO ) + ELSE + CALL ZUNGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), + $ LLWORK, IINFO ) + INDWRK = INDE + N + CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), A, LDA, + $ RWORK( INDWRK ), INFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* Set WORK(1) to optimal complex workspace size. +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of ZHEEV +* + END diff --git a/2.3-1/src/fortran/lapack/zhetd2.f b/2.3-1/src/fortran/lapack/zhetd2.f new file mode 100644 index 00000000..24b0a1df --- /dev/null +++ b/2.3-1/src/fortran/lapack/zhetd2.f @@ -0,0 +1,258 @@ + SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) + COMPLEX*16 A( LDA, * ), TAU( * ) +* .. +* +* 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 .. + COMPLEX*16 ONE, ZERO, HALF + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ), + $ HALF = ( 0.5D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I + COMPLEX*16 ALPHA, TAUI +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZAXPY, ZHEMV, ZHER2, ZLARFG +* .. +* .. External Functions .. + LOGICAL LSAME + COMPLEX*16 ZDOTC + EXTERNAL LSAME, ZDOTC +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETD2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Reduce the upper triangle of A +* + A( N, N ) = DBLE( A( N, N ) ) + DO 10 I = N - 1, 1, -1 +* +* Generate elementary reflector H(i) = I - tau * v * v' +* to annihilate A(1:i-1,i+1) +* + ALPHA = A( I, I+1 ) + CALL ZLARFG( I, ALPHA, A( 1, I+1 ), 1, TAUI ) + E( I ) = ALPHA +* + IF( TAUI.NE.ZERO ) THEN +* +* Apply H(i) from both sides to A(1:i,1:i) +* + A( I, I+1 ) = ONE +* +* Compute x := tau * A * v storing x in TAU(1:i) +* + CALL ZHEMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, + $ TAU, 1 ) +* +* Compute w := x - 1/2 * tau * (x'*v) * v +* + ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, A( 1, I+1 ), 1 ) + CALL ZAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) +* +* Apply the transformation as a rank-2 update: +* A := A - v * w' - w * v' +* + CALL ZHER2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, + $ LDA ) +* + ELSE + A( I, I ) = DBLE( A( I, I ) ) + END IF + A( I, I+1 ) = E( I ) + D( I+1 ) = A( I+1, I+1 ) + TAU( I ) = TAUI + 10 CONTINUE + D( 1 ) = A( 1, 1 ) + ELSE +* +* Reduce the lower triangle of A +* + A( 1, 1 ) = DBLE( A( 1, 1 ) ) + DO 20 I = 1, N - 1 +* +* Generate elementary reflector H(i) = I - tau * v * v' +* to annihilate A(i+2:n,i) +* + ALPHA = A( I+1, I ) + CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAUI ) + E( I ) = ALPHA +* + IF( TAUI.NE.ZERO ) THEN +* +* Apply H(i) from both sides to A(i+1:n,i+1:n) +* + A( I+1, I ) = ONE +* +* Compute x := tau * A * v storing y in TAU(i:n-1) +* + CALL ZHEMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, + $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) +* +* Compute w := x - 1/2 * tau * (x'*v) * v +* + ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, A( I+1, I ), + $ 1 ) + CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) +* +* Apply the transformation as a rank-2 update: +* A := A - v * w' - w * v' +* + CALL ZHER2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, + $ A( I+1, I+1 ), LDA ) +* + ELSE + A( I+1, I+1 ) = DBLE( A( I+1, I+1 ) ) + END IF + A( I+1, I ) = E( I ) + D( I ) = A( I, I ) + TAU( I ) = TAUI + 20 CONTINUE + D( N ) = A( N, N ) + END IF +* + RETURN +* +* End of ZHETD2 +* + END diff --git a/2.3-1/src/fortran/lapack/zhetrd.f b/2.3-1/src/fortran/lapack/zhetrd.f new file mode 100644 index 00000000..fb0cd0b2 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zhetrd.f @@ -0,0 +1,296 @@ + SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZHER2K, ZHETD2, ZLATRD +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. +* + NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NX = N + IWS = 1 + IF( NB.GT.1 .AND. NB.LT.N ) THEN +* +* Determine when to cross over from blocked to unblocked code +* (last block is always handled by unblocked code). +* + NX = MAX( NB, ILAENV( 3, 'ZHETRD', UPLO, N, -1, -1, -1 ) ) + IF( NX.LT.N ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* 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. +* + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = ILAENV( 2, 'ZHETRD', UPLO, N, -1, -1, -1 ) + IF( NB.LT.NBMIN ) + $ NX = N + END IF + ELSE + NX = N + END IF + ELSE + NB = 1 + END IF +* + IF( UPPER ) THEN +* +* Reduce the upper triangle of A. +* Columns 1:kk are handled by the unblocked method. +* + KK = N - ( ( N-NX+NB-1 ) / NB )*NB + DO 20 I = N - NB + 1, KK + 1, -NB +* +* 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 +* + CALL ZLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, + $ LDWORK ) +* +* Update the unreduced submatrix A(1:i-1,1:i-1), using an +* update of the form: A := A - V*W' - W*V' +* + CALL ZHER2K( UPLO, 'No transpose', I-1, NB, -CONE, + $ A( 1, I ), LDA, WORK, LDWORK, ONE, A, LDA ) +* +* Copy superdiagonal elements back into A, and diagonal +* elements into D +* + DO 10 J = I, I + NB - 1 + A( J-1, J ) = E( J-1 ) + D( J ) = A( J, J ) + 10 CONTINUE + 20 CONTINUE +* +* Use unblocked code to reduce the last or only block +* + CALL ZHETD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) + ELSE +* +* Reduce the lower triangle of A +* + DO 40 I = 1, N - NX, NB +* +* 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 +* + CALL ZLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), + $ TAU( I ), WORK, LDWORK ) +* +* Update the unreduced submatrix A(i+nb:n,i+nb:n), using +* an update of the form: A := A - V*W' - W*V' +* + CALL ZHER2K( UPLO, 'No transpose', N-I-NB+1, NB, -CONE, + $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, + $ A( I+NB, I+NB ), LDA ) +* +* Copy subdiagonal elements back into A, and diagonal +* elements into D +* + DO 30 J = I, I + NB - 1 + A( J+1, J ) = E( J ) + D( J ) = A( J, J ) + 30 CONTINUE + 40 CONTINUE +* +* Use unblocked code to reduce the last or only block +* + CALL ZHETD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), + $ TAU( I ), IINFO ) + END IF +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZHETRD +* + END diff --git a/2.3-1/src/fortran/lapack/zhgeqz.f b/2.3-1/src/fortran/lapack/zhgeqz.f new file mode 100644 index 00000000..6a9403bd --- /dev/null +++ b/2.3-1/src/fortran/lapack/zhgeqz.f @@ -0,0 +1,759 @@ + SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, + $ ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, + $ RWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ, JOB + INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 ALPHA( * ), BETA( * ), H( LDH, * ), + $ Q( LDQ, * ), T( LDT, * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* 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 .. + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ILAZR2, ILAZRO, ILQ, ILSCHR, ILZ, LQUERY + INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST, + $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER, + $ JR, MAXIT + DOUBLE PRECISION ABSB, ANORM, ASCALE, ATOL, BNORM, BSCALE, BTOL, + $ C, SAFMIN, TEMP, TEMP2, TEMPR, ULP + COMPLEX*16 ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2, + $ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T1, + $ U12, X +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLANHS + EXTERNAL LSAME, DLAMCH, ZLANHS +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARTG, ZLASET, ZROT, ZSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN, + $ SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION ABS1 +* .. +* .. Statement Function definitions .. + ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) ) +* .. +* .. Executable Statements .. +* +* Decode JOB, COMPQ, COMPZ +* + IF( LSAME( JOB, 'E' ) ) THEN + ILSCHR = .FALSE. + ISCHUR = 1 + ELSE IF( LSAME( JOB, 'S' ) ) THEN + ILSCHR = .TRUE. + ISCHUR = 2 + ELSE + ISCHUR = 0 + END IF +* + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'V' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +* + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'V' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF +* +* Check Argument Values +* + INFO = 0 + WORK( 1 ) = MAX( 1, N ) + LQUERY = ( LWORK.EQ.-1 ) + IF( ISCHUR.EQ.0 ) THEN + INFO = -1 + ELSE IF( ICOMPQ.EQ.0 ) THEN + INFO = -2 + ELSE IF( ICOMPZ.EQ.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( ILO.LT.1 ) THEN + INFO = -5 + ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN + INFO = -6 + ELSE IF( LDH.LT.N ) THEN + INFO = -8 + ELSE IF( LDT.LT.N ) THEN + INFO = -10 + ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN + INFO = -14 + ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN + INFO = -16 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -18 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHGEQZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* +* WORK( 1 ) = CMPLX( 1 ) + IF( N.LE.0 ) THEN + WORK( 1 ) = DCMPLX( 1 ) + RETURN + END IF +* +* Initialize Q and Z +* + IF( ICOMPQ.EQ.3 ) + $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ ) + IF( ICOMPZ.EQ.3 ) + $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) +* +* Machine Constants +* + IN = IHI + 1 - ILO + SAFMIN = DLAMCH( 'S' ) + ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) + ANORM = ZLANHS( 'F', IN, H( ILO, ILO ), LDH, RWORK ) + BNORM = ZLANHS( 'F', IN, T( ILO, ILO ), LDT, RWORK ) + ATOL = MAX( SAFMIN, ULP*ANORM ) + BTOL = MAX( SAFMIN, ULP*BNORM ) + ASCALE = ONE / MAX( SAFMIN, ANORM ) + BSCALE = ONE / MAX( SAFMIN, BNORM ) +* +* +* Set Eigenvalues IHI+1:N +* + DO 10 J = IHI + 1, N + ABSB = ABS( T( J, J ) ) + IF( ABSB.GT.SAFMIN ) THEN + SIGNBC = DCONJG( T( J, J ) / ABSB ) + T( J, J ) = ABSB + IF( ILSCHR ) THEN + CALL ZSCAL( J-1, SIGNBC, T( 1, J ), 1 ) + CALL ZSCAL( J, SIGNBC, H( 1, J ), 1 ) + ELSE + H( J, J ) = H( J, J )*SIGNBC + END IF + IF( ILZ ) + $ CALL ZSCAL( N, SIGNBC, Z( 1, J ), 1 ) + ELSE + T( J, J ) = CZERO + END IF + ALPHA( J ) = H( J, J ) + BETA( J ) = T( J, J ) + 10 CONTINUE +* +* If IHI < ILO, skip QZ steps +* + IF( IHI.LT.ILO ) + $ GO TO 190 +* +* 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 ) THEN + IFRSTM = 1 + ILASTM = N + ELSE + IFRSTM = ILO + ILASTM = IHI + END IF + IITER = 0 + ESHIFT = CZERO + MAXIT = 30*( IHI-ILO+1 ) +* + DO 170 JITER = 1, MAXIT +* +* Check for too many iterations. +* + IF( JITER.GT.MAXIT ) + $ GO TO 180 +* +* 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.EQ.ILO ) THEN + GO TO 60 + ELSE + IF( ABS1( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN + H( ILAST, ILAST-1 ) = CZERO + GO TO 60 + END IF + END IF +* + IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN + T( ILAST, ILAST ) = CZERO + GO TO 50 + END IF +* +* General case: j= 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 .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I + COMPLEX*16 ALPHA +* .. +* .. External Subroutines .. + EXTERNAL ZGEMV, ZLACGV, ZLARFG, ZSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* + IF( M.GE.N ) THEN +* +* Reduce to upper bidiagonal form +* + DO 10 I = 1, NB +* +* Update A(i:m,i) +* + CALL ZLACGV( I-1, Y( I, 1 ), LDY ) + CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ), + $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 ) + CALL ZLACGV( I-1, Y( I, 1 ), LDY ) + CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), + $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 ) +* +* Generate reflection Q(i) to annihilate A(i+1:m,i) +* + ALPHA = A( I, I ) + CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1, + $ TAUQ( I ) ) + D( I ) = ALPHA + IF( I.LT.N ) THEN + A( I, I ) = ONE +* +* Compute Y(i+1:n,i) +* + CALL ZGEMV( 'Conjugate transpose', M-I+1, N-I, ONE, + $ A( I, I+1 ), LDA, A( I, I ), 1, ZERO, + $ Y( I+1, I ), 1 ) + CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE, + $ A( I, 1 ), LDA, A( I, I ), 1, ZERO, + $ Y( 1, I ), 1 ) + CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), + $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) + CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE, + $ X( I, 1 ), LDX, A( I, I ), 1, ZERO, + $ Y( 1, I ), 1 ) + CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE, + $ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE, + $ Y( I+1, I ), 1 ) + CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) +* +* Update A(i,i+1:n) +* + CALL ZLACGV( N-I, A( I, I+1 ), LDA ) + CALL ZLACGV( I, A( I, 1 ), LDA ) + CALL ZGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ), + $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA ) + CALL ZLACGV( I, A( I, 1 ), LDA ) + CALL ZLACGV( I-1, X( I, 1 ), LDX ) + CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE, + $ A( 1, I+1 ), LDA, X( I, 1 ), LDX, ONE, + $ A( I, I+1 ), LDA ) + CALL ZLACGV( I-1, X( I, 1 ), LDX ) +* +* Generate reflection P(i) to annihilate A(i,i+2:n) +* + ALPHA = A( I, I+1 ) + CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA, + $ TAUP( I ) ) + E( I ) = ALPHA + A( I, I+1 ) = ONE +* +* Compute X(i+1:m,i) +* + CALL ZGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ), + $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 ) + CALL ZGEMV( 'Conjugate transpose', N-I, I, ONE, + $ Y( I+1, 1 ), LDY, A( I, I+1 ), LDA, ZERO, + $ X( 1, I ), 1 ) + CALL ZGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), + $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) + CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), + $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) + CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), + $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) + CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) + CALL ZLACGV( N-I, A( I, I+1 ), LDA ) + END IF + 10 CONTINUE + ELSE +* +* Reduce to lower bidiagonal form +* + DO 20 I = 1, NB +* +* Update A(i,i:n) +* + CALL ZLACGV( N-I+1, A( I, I ), LDA ) + CALL ZLACGV( I-1, A( I, 1 ), LDA ) + CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ), + $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA ) + CALL ZLACGV( I-1, A( I, 1 ), LDA ) + CALL ZLACGV( I-1, X( I, 1 ), LDX ) + CALL ZGEMV( 'Conjugate transpose', I-1, N-I+1, -ONE, + $ A( 1, I ), LDA, X( I, 1 ), LDX, ONE, A( I, I ), + $ LDA ) + CALL ZLACGV( I-1, X( I, 1 ), LDX ) +* +* Generate reflection P(i) to annihilate A(i,i+1:n) +* + ALPHA = A( I, I ) + CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, + $ TAUP( I ) ) + D( I ) = ALPHA + IF( I.LT.M ) THEN + A( I, I ) = ONE +* +* Compute X(i+1:m,i) +* + CALL ZGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), + $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 ) + CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1, ONE, + $ Y( I, 1 ), LDY, A( I, I ), LDA, ZERO, + $ X( 1, I ), 1 ) + CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), + $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) + CALL ZGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), + $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 ) + CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), + $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) + CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) + CALL ZLACGV( N-I+1, A( I, I ), LDA ) +* +* Update A(i+1:m,i) +* + CALL ZLACGV( I-1, Y( I, 1 ), LDY ) + CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), + $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 ) + CALL ZLACGV( I-1, Y( I, 1 ), LDY ) + CALL ZGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), + $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 ) +* +* Generate reflection Q(i) to annihilate A(i+2:m,i) +* + ALPHA = A( I+1, I ) + CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1, + $ TAUQ( I ) ) + E( I ) = ALPHA + A( I+1, I ) = ONE +* +* Compute Y(i+1:n,i) +* + CALL ZGEMV( 'Conjugate transpose', M-I, N-I, ONE, + $ A( I+1, I+1 ), LDA, A( I+1, I ), 1, ZERO, + $ Y( I+1, I ), 1 ) + CALL ZGEMV( 'Conjugate transpose', M-I, I-1, ONE, + $ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO, + $ Y( 1, I ), 1 ) + CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), + $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) + CALL ZGEMV( 'Conjugate transpose', M-I, I, ONE, + $ X( I+1, 1 ), LDX, A( I+1, I ), 1, ZERO, + $ Y( 1, I ), 1 ) + CALL ZGEMV( 'Conjugate transpose', I, N-I, -ONE, + $ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE, + $ Y( I+1, I ), 1 ) + CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) + ELSE + CALL ZLACGV( N-I+1, A( I, I ), LDA ) + END IF + 20 CONTINUE + END IF + RETURN +* +* End of ZLABRD +* + END diff --git a/2.3-1/src/fortran/lapack/zlacgv.f b/2.3-1/src/fortran/lapack/zlacgv.f new file mode 100644 index 00000000..0033e306 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlacgv.f @@ -0,0 +1,60 @@ + SUBROUTINE ZLACGV( N, X, INCX ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, N +* .. +* .. Array Arguments .. + COMPLEX*16 X( * ) +* .. +* +* 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 .. + INTEGER I, IOFF +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* .. Executable Statements .. +* + IF( INCX.EQ.1 ) THEN + DO 10 I = 1, N + X( I ) = DCONJG( X( I ) ) + 10 CONTINUE + ELSE + IOFF = 1 + IF( INCX.LT.0 ) + $ IOFF = 1 - ( N-1 )*INCX + DO 20 I = 1, N + X( IOFF ) = DCONJG( X( IOFF ) ) + IOFF = IOFF + INCX + 20 CONTINUE + END IF + RETURN +* +* End of ZLACGV +* + END diff --git a/2.3-1/src/fortran/lapack/zlacn2.f b/2.3-1/src/fortran/lapack/zlacn2.f new file mode 100644 index 00000000..99f7ae35 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlacn2.f @@ -0,0 +1,221 @@ + SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER KASE, N + DOUBLE PRECISION EST +* .. +* .. Array Arguments .. + INTEGER ISAVE( 3 ) + COMPLEX*16 V( * ), X( * ) +* .. +* +* 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 .. + INTEGER ITMAX + PARAMETER ( ITMAX = 5 ) + DOUBLE PRECISION ONE, TWO + PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), + $ CONE = ( 1.0D0, 0.0D0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, JLAST + DOUBLE PRECISION ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP +* .. +* .. External Functions .. + INTEGER IZMAX1 + DOUBLE PRECISION DLAMCH, DZSUM1 + EXTERNAL IZMAX1, DLAMCH, DZSUM1 +* .. +* .. External Subroutines .. + EXTERNAL ZCOPY +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG +* .. +* .. Executable Statements .. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + IF( KASE.EQ.0 ) THEN + DO 10 I = 1, N + X( I ) = DCMPLX( ONE / DBLE( N ) ) + 10 CONTINUE + KASE = 1 + ISAVE( 1 ) = 1 + RETURN + END IF +* + GO TO ( 20, 40, 70, 90, 120 )ISAVE( 1 ) +* +* ................ ENTRY (ISAVE( 1 ) = 1) +* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. +* + 20 CONTINUE + IF( N.EQ.1 ) THEN + V( 1 ) = X( 1 ) + EST = ABS( V( 1 ) ) +* ... QUIT + GO TO 130 + END IF + EST = DZSUM1( N, X, 1 ) +* + DO 30 I = 1, N + ABSXI = ABS( X( I ) ) + IF( ABSXI.GT.SAFMIN ) THEN + X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, + $ DIMAG( X( I ) ) / ABSXI ) + ELSE + X( I ) = CONE + END IF + 30 CONTINUE + KASE = 2 + ISAVE( 1 ) = 2 + RETURN +* +* ................ ENTRY (ISAVE( 1 ) = 2) +* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. +* + 40 CONTINUE + ISAVE( 2 ) = IZMAX1( N, X, 1 ) + ISAVE( 3 ) = 2 +* +* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. +* + 50 CONTINUE + DO 60 I = 1, N + X( I ) = CZERO + 60 CONTINUE + X( ISAVE( 2 ) ) = CONE + KASE = 1 + ISAVE( 1 ) = 3 + RETURN +* +* ................ ENTRY (ISAVE( 1 ) = 3) +* X HAS BEEN OVERWRITTEN BY A*X. +* + 70 CONTINUE + CALL ZCOPY( N, X, 1, V, 1 ) + ESTOLD = EST + EST = DZSUM1( N, V, 1 ) +* +* TEST FOR CYCLING. + IF( EST.LE.ESTOLD ) + $ GO TO 100 +* + DO 80 I = 1, N + ABSXI = ABS( X( I ) ) + IF( ABSXI.GT.SAFMIN ) THEN + X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, + $ DIMAG( X( I ) ) / ABSXI ) + ELSE + X( I ) = CONE + END IF + 80 CONTINUE + KASE = 2 + ISAVE( 1 ) = 4 + RETURN +* +* ................ ENTRY (ISAVE( 1 ) = 4) +* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. +* + 90 CONTINUE + JLAST = ISAVE( 2 ) + ISAVE( 2 ) = IZMAX1( N, X, 1 ) + IF( ( ABS( X( JLAST ) ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. + $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN + ISAVE( 3 ) = ISAVE( 3 ) + 1 + GO TO 50 + END IF +* +* ITERATION COMPLETE. FINAL STAGE. +* + 100 CONTINUE + ALTSGN = ONE + DO 110 I = 1, N + X( I ) = DCMPLX( ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) ) + ALTSGN = -ALTSGN + 110 CONTINUE + KASE = 1 + ISAVE( 1 ) = 5 + RETURN +* +* ................ ENTRY (ISAVE( 1 ) = 5) +* X HAS BEEN OVERWRITTEN BY A*X. +* + 120 CONTINUE + TEMP = TWO*( DZSUM1( N, X, 1 ) / DBLE( 3*N ) ) + IF( TEMP.GT.EST ) THEN + CALL ZCOPY( N, X, 1, V, 1 ) + EST = TEMP + END IF +* + 130 CONTINUE + KASE = 0 + RETURN +* +* End of ZLACN2 +* + END diff --git a/2.3-1/src/fortran/lapack/zlacon.f b/2.3-1/src/fortran/lapack/zlacon.f new file mode 100644 index 00000000..5773ef92 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlacon.f @@ -0,0 +1,212 @@ + SUBROUTINE ZLACON( N, V, X, EST, KASE ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER KASE, N + DOUBLE PRECISION EST +* .. +* .. Array Arguments .. + COMPLEX*16 V( N ), X( N ) +* .. +* +* 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 .. + INTEGER ITMAX + PARAMETER ( ITMAX = 5 ) + DOUBLE PRECISION ONE, TWO + PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), + $ CONE = ( 1.0D0, 0.0D0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, ITER, J, JLAST, JUMP + DOUBLE PRECISION ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP +* .. +* .. External Functions .. + INTEGER IZMAX1 + DOUBLE PRECISION DLAMCH, DZSUM1 + EXTERNAL IZMAX1, DLAMCH, DZSUM1 +* .. +* .. External Subroutines .. + EXTERNAL ZCOPY +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG +* .. +* .. Save statement .. + SAVE +* .. +* .. Executable Statements .. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + IF( KASE.EQ.0 ) THEN + DO 10 I = 1, N + X( I ) = DCMPLX( ONE / DBLE( N ) ) + 10 CONTINUE + KASE = 1 + JUMP = 1 + RETURN + END IF +* + GO TO ( 20, 40, 70, 90, 120 )JUMP +* +* ................ ENTRY (JUMP = 1) +* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. +* + 20 CONTINUE + IF( N.EQ.1 ) THEN + V( 1 ) = X( 1 ) + EST = ABS( V( 1 ) ) +* ... QUIT + GO TO 130 + END IF + EST = DZSUM1( N, X, 1 ) +* + DO 30 I = 1, N + ABSXI = ABS( X( I ) ) + IF( ABSXI.GT.SAFMIN ) THEN + X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, + $ DIMAG( X( I ) ) / ABSXI ) + ELSE + X( I ) = CONE + END IF + 30 CONTINUE + KASE = 2 + JUMP = 2 + RETURN +* +* ................ ENTRY (JUMP = 2) +* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. +* + 40 CONTINUE + J = IZMAX1( N, X, 1 ) + ITER = 2 +* +* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. +* + 50 CONTINUE + DO 60 I = 1, N + X( I ) = CZERO + 60 CONTINUE + X( J ) = CONE + KASE = 1 + JUMP = 3 + RETURN +* +* ................ ENTRY (JUMP = 3) +* X HAS BEEN OVERWRITTEN BY A*X. +* + 70 CONTINUE + CALL ZCOPY( N, X, 1, V, 1 ) + ESTOLD = EST + EST = DZSUM1( N, V, 1 ) +* +* TEST FOR CYCLING. + IF( EST.LE.ESTOLD ) + $ GO TO 100 +* + DO 80 I = 1, N + ABSXI = ABS( X( I ) ) + IF( ABSXI.GT.SAFMIN ) THEN + X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, + $ DIMAG( X( I ) ) / ABSXI ) + ELSE + X( I ) = CONE + END IF + 80 CONTINUE + KASE = 2 + JUMP = 4 + RETURN +* +* ................ ENTRY (JUMP = 4) +* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. +* + 90 CONTINUE + JLAST = J + J = IZMAX1( N, X, 1 ) + IF( ( ABS( X( JLAST ) ).NE.ABS( X( J ) ) ) .AND. + $ ( ITER.LT.ITMAX ) ) THEN + ITER = ITER + 1 + GO TO 50 + END IF +* +* ITERATION COMPLETE. FINAL STAGE. +* + 100 CONTINUE + ALTSGN = ONE + DO 110 I = 1, N + X( I ) = DCMPLX( ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) ) + ALTSGN = -ALTSGN + 110 CONTINUE + KASE = 1 + JUMP = 5 + RETURN +* +* ................ ENTRY (JUMP = 5) +* X HAS BEEN OVERWRITTEN BY A*X. +* + 120 CONTINUE + TEMP = TWO*( DZSUM1( N, X, 1 ) / DBLE( 3*N ) ) + IF( TEMP.GT.EST ) THEN + CALL ZCOPY( N, X, 1, V, 1 ) + EST = TEMP + END IF +* + 130 CONTINUE + KASE = 0 + RETURN +* +* End of ZLACON +* + END diff --git a/2.3-1/src/fortran/lapack/zlacpy.f b/2.3-1/src/fortran/lapack/zlacpy.f new file mode 100644 index 00000000..8878311a --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlacpy.f @@ -0,0 +1,90 @@ + SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* 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 .. + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, MIN( J, M ) + B( I, J ) = A( I, J ) + 10 CONTINUE + 20 CONTINUE +* + ELSE IF( LSAME( UPLO, 'L' ) ) THEN + DO 40 J = 1, N + DO 30 I = J, M + B( I, J ) = A( I, J ) + 30 CONTINUE + 40 CONTINUE +* + ELSE + DO 60 J = 1, N + DO 50 I = 1, M + B( I, J ) = A( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + RETURN +* +* End of ZLACPY +* + END diff --git a/2.3-1/src/fortran/lapack/zladiv.f b/2.3-1/src/fortran/lapack/zladiv.f new file mode 100644 index 00000000..4a12055e --- /dev/null +++ b/2.3-1/src/fortran/lapack/zladiv.f @@ -0,0 +1,46 @@ + COMPLEX*16 FUNCTION ZLADIV( X, Y ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + COMPLEX*16 X, Y +* .. +* +* 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 .. + DOUBLE PRECISION ZI, ZR +* .. +* .. External Subroutines .. + EXTERNAL DLADIV +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, DIMAG +* .. +* .. Executable Statements .. +* + CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR, + $ ZI ) + ZLADIV = DCMPLX( ZR, ZI ) +* + RETURN +* +* End of ZLADIV +* + END diff --git a/2.3-1/src/fortran/lapack/zlahqr.f b/2.3-1/src/fortran/lapack/zlahqr.f new file mode 100644 index 00000000..9ce9be19 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlahqr.f @@ -0,0 +1,470 @@ + SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * ) +* .. +* +* 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 .. + INTEGER ITMAX + PARAMETER ( ITMAX = 30 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE, HALF + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0, HALF = 0.5d0 ) + DOUBLE PRECISION DAT1 + PARAMETER ( DAT1 = 3.0d0 / 4.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U, + $ V2, X, Y + DOUBLE PRECISION AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX, + $ SAFMIN, SMLNUM, SX, T2, TST, ULP + INTEGER I, I1, I2, ITS, J, JHI, JLO, K, L, M, NH, NZ +* .. +* .. Local Arrays .. + COMPLEX*16 V( 2 ) +* .. +* .. External Functions .. + COMPLEX*16 ZLADIV + DOUBLE PRECISION DLAMCH + EXTERNAL ZLADIV, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, ZCOPY, ZLARFG, ZSCAL +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + IF( ILO.EQ.IHI ) THEN + W( ILO ) = H( ILO, ILO ) + RETURN + END IF +* +* ==== clear out the trash ==== + DO 10 J = ILO, IHI - 3 + H( J+2, J ) = ZERO + H( J+3, J ) = ZERO + 10 CONTINUE + IF( ILO.LE.IHI-2 ) + $ H( IHI, IHI-2 ) = ZERO +* ==== ensure that subdiagonal entries are real ==== + DO 20 I = ILO + 1, IHI + IF( DIMAG( H( I, I-1 ) ).NE.RZERO ) THEN +* ==== The following redundant normalization +* . avoids problems with both gradual and +* . sudden underflow in ABS(H(I,I-1)) ==== + SC = H( I, I-1 ) / CABS1( H( I, I-1 ) ) + SC = DCONJG( SC ) / ABS( SC ) + H( I, I-1 ) = ABS( H( I, I-1 ) ) + IF( WANTT ) THEN + JLO = 1 + JHI = N + ELSE + JLO = ILO + JHI = IHI + END IF + CALL ZSCAL( JHI-I+1, SC, H( I, I ), LDH ) + CALL ZSCAL( MIN( JHI, I+1 )-JLO+1, DCONJG( SC ), + $ H( JLO, I ), 1 ) + IF( WANTZ ) + $ CALL ZSCAL( IHIZ-ILOZ+1, DCONJG( SC ), Z( ILOZ, I ), 1 ) + END IF + 20 CONTINUE +* + NH = IHI - ILO + 1 + NZ = IHIZ - ILOZ + 1 +* +* Set machine-dependent constants for the stopping criterion. +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( 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 ) THEN + I1 = 1 + I2 = N + END IF +* +* 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 + 30 CONTINUE + IF( I.LT.ILO ) + $ GO TO 150 +* +* 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 + DO 130 ITS = 0, ITMAX +* +* Look for a single small subdiagonal element. +* + DO 40 K = I, L + 1, -1 + IF( CABS1( H( K, K-1 ) ).LE.SMLNUM ) + $ GO TO 50 + TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) + IF( TST.EQ.ZERO ) THEN + IF( K-2.GE.ILO ) + $ TST = TST + ABS( DBLE( H( K-1, K-2 ) ) ) + IF( K+1.LE.IHI ) + $ TST = TST + ABS( DBLE( H( K+1, K ) ) ) + END IF +* ==== 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. ==== + IF( ABS( DBLE( H( K, K-1 ) ) ).LE.ULP*TST ) THEN + AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) + BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) + AA = MAX( CABS1( H( K, K ) ), + $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) + BB = MIN( CABS1( H( K, K ) ), + $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) + S = AA + AB + IF( BA*( AB / S ).LE.MAX( SMLNUM, + $ ULP*( BB*( AA / S ) ) ) )GO TO 50 + END IF + 40 CONTINUE + 50 CONTINUE + L = K + IF( L.GT.ILO ) THEN +* +* H(L,L-1) is negligible +* + H( L, L-1 ) = ZERO + END IF +* +* Exit from loop if a submatrix of order 1 has split off. +* + IF( L.GE.I ) + $ GO TO 140 +* +* 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( .NOT.WANTT ) THEN + I1 = L + I2 = I + END IF +* + IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN +* +* Exceptional shift. +* + S = DAT1*ABS( DBLE( H( I, I-1 ) ) ) + T = S + H( I, I ) + ELSE +* +* Wilkinson's shift. +* + T = H( I, I ) + U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) ) + S = CABS1( U ) + IF( S.NE.RZERO ) THEN + X = HALF*( H( I-1, I-1 )-T ) + SX = CABS1( X ) + S = MAX( S, CABS1( X ) ) + Y = S*SQRT( ( X / S )**2+( U / S )**2 ) + IF( SX.GT.RZERO ) THEN + IF( DBLE( X / SX )*DBLE( Y )+DIMAG( X / SX )* + $ DIMAG( Y ).LT.RZERO )Y = -Y + END IF + T = T - U*ZLADIV( U, ( X+Y ) ) + END IF + END IF +* +* Look for two consecutive small subdiagonal elements. +* + DO 60 M = I - 1, L + 1, -1 +* +* Determine the effect of starting the single-shift QR +* iteration at row M, and see if this would make H(M,M-1) +* negligible. +* + H11 = H( M, M ) + H22 = H( M+1, M+1 ) + H11S = H11 - T + H21 = H( M+1, M ) + S = CABS1( H11S ) + ABS( H21 ) + H11S = H11S / S + H21 = H21 / S + V( 1 ) = H11S + V( 2 ) = H21 + H10 = H( M, M-1 ) + IF( ABS( H10 )*ABS( H21 ).LE.ULP* + $ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) ) + $ GO TO 70 + 60 CONTINUE + H11 = H( L, L ) + H22 = H( L+1, L+1 ) + H11S = H11 - T + H21 = H( L+1, L ) + S = CABS1( H11S ) + ABS( H21 ) + H11S = H11S / S + H21 = H21 / S + V( 1 ) = H11S + V( 2 ) = H21 + 70 CONTINUE +* +* Single-shift QR step +* + DO 120 K = M, I - 1 +* +* 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.GT.M ) + $ CALL ZCOPY( 2, H( K, K-1 ), 1, V, 1 ) + CALL ZLARFG( 2, V( 1 ), V( 2 ), 1, T1 ) + IF( K.GT.M ) THEN + H( K, K-1 ) = V( 1 ) + H( K+1, K-1 ) = ZERO + END IF + V2 = V( 2 ) + T2 = DBLE( T1*V2 ) +* +* Apply G from the left to transform the rows of the matrix +* in columns K to I2. +* + DO 80 J = K, I2 + SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J ) + H( K, J ) = H( K, J ) - SUM + H( K+1, J ) = H( K+1, J ) - SUM*V2 + 80 CONTINUE +* +* Apply G from the right to transform the columns of the +* matrix in rows I1 to min(K+2,I). +* + DO 90 J = I1, MIN( K+2, I ) + SUM = T1*H( J, K ) + T2*H( J, K+1 ) + H( J, K ) = H( J, K ) - SUM + H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 ) + 90 CONTINUE +* + IF( WANTZ ) THEN +* +* Accumulate transformations in the matrix Z +* + DO 100 J = ILOZ, IHIZ + SUM = T1*Z( J, K ) + T2*Z( J, K+1 ) + Z( J, K ) = Z( J, K ) - SUM + Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 ) + 100 CONTINUE + END IF +* + IF( K.EQ.M .AND. M.GT.L ) THEN +* +* 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. +* + TEMP = ONE - T1 + TEMP = TEMP / ABS( TEMP ) + H( M+1, M ) = H( M+1, M )*DCONJG( TEMP ) + IF( M+2.LE.I ) + $ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP + DO 110 J = M, I + IF( J.NE.M+1 ) THEN + IF( I2.GT.J ) + $ CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH ) + CALL ZSCAL( J-I1, DCONJG( TEMP ), H( I1, J ), 1 ) + IF( WANTZ ) THEN + CALL ZSCAL( NZ, DCONJG( TEMP ), Z( ILOZ, J ), + $ 1 ) + END IF + END IF + 110 CONTINUE + END IF + 120 CONTINUE +* +* Ensure that H(I,I-1) is real. +* + TEMP = H( I, I-1 ) + IF( DIMAG( TEMP ).NE.RZERO ) THEN + RTEMP = ABS( TEMP ) + H( I, I-1 ) = RTEMP + TEMP = TEMP / RTEMP + IF( I2.GT.I ) + $ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH ) + CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 ) + IF( WANTZ ) THEN + CALL ZSCAL( NZ, TEMP, Z( ILOZ, I ), 1 ) + END IF + END IF +* + 130 CONTINUE +* +* Failure to converge in remaining number of iterations +* + INFO = I + RETURN +* + 140 CONTINUE +* +* H(I,I-1) is negligible: one eigenvalue has converged. +* + W( I ) = H( I, I ) +* +* return to start of the main loop with new value of I. +* + I = L - 1 + GO TO 30 +* + 150 CONTINUE + RETURN +* +* End of ZLAHQR +* + END diff --git a/2.3-1/src/fortran/lapack/zlahr2.f b/2.3-1/src/fortran/lapack/zlahr2.f new file mode 100644 index 00000000..f3cb5515 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlahr2.f @@ -0,0 +1,240 @@ + SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER K, LDA, LDT, LDY, N, NB +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), + $ Y( LDY, NB ) +* .. +* +* 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 .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I + COMPLEX*16 EI +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZCOPY, ZGEMM, ZGEMV, ZLACPY, + $ ZLARFG, ZSCAL, ZTRMM, ZTRMV, ZLACGV +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* + DO 10 I = 1, NB + IF( I.GT.1 ) THEN +* +* Update A(K+1:N,I) +* +* Update I-th column of A - Y * V' +* + CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) + CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, + $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) + CALL ZLACGV( I-1, A( K+I-1, 1 ), 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 +* + CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) + CALL ZTRMV( 'Lower', 'Conjugate transpose', 'UNIT', + $ I-1, A( K+1, 1 ), + $ LDA, T( 1, NB ), 1 ) +* +* w := w + V2'*b2 +* + CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), + $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) +* +* w := T'*w +* + CALL ZTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, NB ), 1 ) +* +* b2 := b2 - V2*w +* + CALL ZGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, + $ A( K+I, 1 ), + $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) +* +* b1 := b1 - V1*w +* + CALL ZTRMV( 'Lower', 'NO TRANSPOSE', + $ 'UNIT', I-1, + $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) + CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) +* + A( K+I-1, I-1 ) = EI + END IF +* +* Generate the elementary reflector H(I) to annihilate +* A(K+I+1:N,I) +* + CALL ZLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, + $ TAU( I ) ) + EI = A( K+I, I ) + A( K+I, I ) = ONE +* +* Compute Y(K+1:N,I) +* + CALL ZGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, + $ ONE, A( K+1, I+1 ), + $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) + CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), LDA, + $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) + CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, + $ Y( K+1, 1 ), LDY, + $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) + CALL ZSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) +* +* Compute T(1:I,I) +* + CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) + CALL ZTRMV( 'Upper', 'No Transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, I ), 1 ) + T( I, I ) = TAU( I ) +* + 10 CONTINUE + A( K+NB, NB ) = EI +* +* Compute Y(1:K,1:NB) +* + CALL ZLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) + CALL ZTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', + $ 'UNIT', K, NB, + $ ONE, A( K+1, 1 ), LDA, Y, LDY ) + IF( N.GT.K+NB ) + $ CALL ZGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, + $ NB, N-K-NB, ONE, + $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, + $ LDY ) + CALL ZTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', + $ 'NON-UNIT', K, NB, + $ ONE, T, LDT, Y, LDY ) +* + RETURN +* +* End of ZLAHR2 +* + END diff --git a/2.3-1/src/fortran/lapack/zlahrd.f b/2.3-1/src/fortran/lapack/zlahrd.f new file mode 100644 index 00000000..e7eb9de9 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlahrd.f @@ -0,0 +1,213 @@ + SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER K, LDA, LDT, LDY, N, NB +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), + $ Y( LDY, NB ) +* .. +* +* 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 .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I + COMPLEX*16 EI +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZCOPY, ZGEMV, ZLACGV, ZLARFG, ZSCAL, + $ ZTRMV +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* + DO 10 I = 1, NB + IF( I.GT.1 ) THEN +* +* Update A(1:n,i) +* +* Compute i-th column of A - Y * V' +* + CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) + CALL ZGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, + $ A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 1 ) + CALL ZLACGV( I-1, A( K+I-1, 1 ), 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 +* + CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) + CALL ZTRMV( 'Lower', 'Conjugate transpose', 'Unit', I-1, + $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) +* +* w := w + V2'*b2 +* + CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, ONE, + $ A( K+I, 1 ), LDA, A( K+I, I ), 1, ONE, + $ T( 1, NB ), 1 ) +* +* w := T'*w +* + CALL ZTRMV( 'Upper', 'Conjugate transpose', 'Non-unit', I-1, + $ T, LDT, T( 1, NB ), 1 ) +* +* b2 := b2 - V2*w +* + CALL ZGEMV( 'No transpose', N-K-I+1, I-1, -ONE, A( K+I, 1 ), + $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) +* +* b1 := b1 - V1*w +* + CALL ZTRMV( 'Lower', 'No transpose', 'Unit', I-1, + $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) + CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) +* + A( K+I-1, I-1 ) = EI + END IF +* +* Generate the elementary reflector H(i) to annihilate +* A(k+i+1:n,i) +* + EI = A( K+I, I ) + CALL ZLARFG( N-K-I+1, EI, A( MIN( K+I+1, N ), I ), 1, + $ TAU( I ) ) + A( K+I, I ) = ONE +* +* Compute Y(1:n,i) +* + CALL ZGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA, + $ A( K+I, I ), 1, ZERO, Y( 1, I ), 1 ) + CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, ONE, + $ A( K+I, 1 ), LDA, A( K+I, I ), 1, ZERO, T( 1, I ), + $ 1 ) + CALL ZGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, T( 1, I ), 1, + $ ONE, Y( 1, I ), 1 ) + CALL ZSCAL( N, TAU( I ), Y( 1, I ), 1 ) +* +* Compute T(1:i,i) +* + CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) + CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, LDT, + $ T( 1, I ), 1 ) + T( I, I ) = TAU( I ) +* + 10 CONTINUE + A( K+NB, NB ) = EI +* + RETURN +* +* End of ZLAHRD +* + END diff --git a/2.3-1/src/fortran/lapack/zlaic1.f b/2.3-1/src/fortran/lapack/zlaic1.f new file mode 100644 index 00000000..589f0889 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlaic1.f @@ -0,0 +1,295 @@ + SUBROUTINE ZLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER J, JOB + DOUBLE PRECISION SEST, SESTPR + COMPLEX*16 C, GAMMA, S +* .. +* .. Array Arguments .. + COMPLEX*16 W( J ), X( J ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) + DOUBLE PRECISION HALF, FOUR + PARAMETER ( HALF = 0.5D0, FOUR = 4.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION ABSALP, ABSEST, ABSGAM, B, EPS, NORMA, S1, S2, + $ SCL, T, TEST, TMP, ZETA1, ZETA2 + COMPLEX*16 ALPHA, COSINE, SINE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DCONJG, MAX, SQRT +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + COMPLEX*16 ZDOTC + EXTERNAL DLAMCH, ZDOTC +* .. +* .. Executable Statements .. +* + EPS = DLAMCH( 'Epsilon' ) + ALPHA = ZDOTC( J, X, 1, W, 1 ) +* + ABSALP = ABS( ALPHA ) + ABSGAM = ABS( GAMMA ) + ABSEST = ABS( SEST ) +* + IF( JOB.EQ.1 ) THEN +* +* Estimating largest singular value +* +* special cases +* + IF( SEST.EQ.ZERO ) THEN + S1 = MAX( ABSGAM, ABSALP ) + IF( S1.EQ.ZERO ) THEN + S = ZERO + C = ONE + SESTPR = ZERO + ELSE + S = ALPHA / S1 + C = GAMMA / S1 + TMP = SQRT( S*DCONJG( S )+C*DCONJG( C ) ) + S = S / TMP + C = C / TMP + SESTPR = S1*TMP + END IF + RETURN + ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN + S = ONE + C = ZERO + TMP = MAX( ABSEST, ABSALP ) + S1 = ABSEST / TMP + S2 = ABSALP / TMP + SESTPR = TMP*SQRT( S1*S1+S2*S2 ) + RETURN + ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN + S1 = ABSGAM + S2 = ABSEST + IF( S1.LE.S2 ) THEN + S = ONE + C = ZERO + SESTPR = S2 + ELSE + S = ZERO + C = ONE + SESTPR = S1 + END IF + RETURN + ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN + S1 = ABSGAM + S2 = ABSALP + IF( S1.LE.S2 ) THEN + TMP = S1 / S2 + SCL = SQRT( ONE+TMP*TMP ) + SESTPR = S2*SCL + S = ( ALPHA / S2 ) / SCL + C = ( GAMMA / S2 ) / SCL + ELSE + TMP = S2 / S1 + SCL = SQRT( ONE+TMP*TMP ) + SESTPR = S1*SCL + S = ( ALPHA / S1 ) / SCL + C = ( GAMMA / S1 ) / SCL + END IF + RETURN + ELSE +* +* normal case +* + ZETA1 = ABSALP / ABSEST + ZETA2 = ABSGAM / ABSEST +* + B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF + C = ZETA1*ZETA1 + IF( B.GT.ZERO ) THEN + T = C / ( B+SQRT( B*B+C ) ) + ELSE + T = SQRT( B*B+C ) - B + END IF +* + SINE = -( ALPHA / ABSEST ) / T + COSINE = -( GAMMA / ABSEST ) / ( ONE+T ) + TMP = SQRT( SINE*DCONJG( SINE )+COSINE*DCONJG( COSINE ) ) + S = SINE / TMP + C = COSINE / TMP + SESTPR = SQRT( T+ONE )*ABSEST + RETURN + END IF +* + ELSE IF( JOB.EQ.2 ) THEN +* +* Estimating smallest singular value +* +* special cases +* + IF( SEST.EQ.ZERO ) THEN + SESTPR = ZERO + IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN + SINE = ONE + COSINE = ZERO + ELSE + SINE = -DCONJG( GAMMA ) + COSINE = DCONJG( ALPHA ) + END IF + S1 = MAX( ABS( SINE ), ABS( COSINE ) ) + S = SINE / S1 + C = COSINE / S1 + TMP = SQRT( S*DCONJG( S )+C*DCONJG( C ) ) + S = S / TMP + C = C / TMP + RETURN + ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN + S = ZERO + C = ONE + SESTPR = ABSGAM + RETURN + ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN + S1 = ABSGAM + S2 = ABSEST + IF( S1.LE.S2 ) THEN + S = ZERO + C = ONE + SESTPR = S1 + ELSE + S = ONE + C = ZERO + SESTPR = S2 + END IF + RETURN + ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN + S1 = ABSGAM + S2 = ABSALP + IF( S1.LE.S2 ) THEN + TMP = S1 / S2 + SCL = SQRT( ONE+TMP*TMP ) + SESTPR = ABSEST*( TMP / SCL ) + S = -( DCONJG( GAMMA ) / S2 ) / SCL + C = ( DCONJG( ALPHA ) / S2 ) / SCL + ELSE + TMP = S2 / S1 + SCL = SQRT( ONE+TMP*TMP ) + SESTPR = ABSEST / SCL + S = -( DCONJG( GAMMA ) / S1 ) / SCL + C = ( DCONJG( ALPHA ) / S1 ) / SCL + END IF + RETURN + ELSE +* +* normal case +* + ZETA1 = ABSALP / ABSEST + ZETA2 = ABSGAM / ABSEST +* + NORMA = MAX( ONE+ZETA1*ZETA1+ZETA1*ZETA2, + $ ZETA1*ZETA2+ZETA2*ZETA2 ) +* +* See if root is closer to zero or to ONE +* + TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 ) + IF( TEST.GE.ZERO ) THEN +* +* root is close to zero, compute directly +* + B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF + C = ZETA2*ZETA2 + T = C / ( B+SQRT( ABS( B*B-C ) ) ) + SINE = ( ALPHA / ABSEST ) / ( ONE-T ) + COSINE = -( GAMMA / ABSEST ) / T + SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST + ELSE +* +* root is closer to ONE, shift by that amount +* + B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF + C = ZETA1*ZETA1 + IF( B.GE.ZERO ) THEN + T = -C / ( B+SQRT( B*B+C ) ) + ELSE + T = B - SQRT( B*B+C ) + END IF + SINE = -( ALPHA / ABSEST ) / T + COSINE = -( GAMMA / ABSEST ) / ( ONE+T ) + SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST + END IF + TMP = SQRT( SINE*DCONJG( SINE )+COSINE*DCONJG( COSINE ) ) + S = SINE / TMP + C = COSINE / TMP + RETURN +* + END IF + END IF + RETURN +* +* End of ZLAIC1 +* + END diff --git a/2.3-1/src/fortran/lapack/zlange.f b/2.3-1/src/fortran/lapack/zlange.f new file mode 100644 index 00000000..36cecbdc --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlange.f @@ -0,0 +1,145 @@ + DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION WORK( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION SCALE, SUM, VALUE +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + IF( MIN( M, N ).EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + VALUE = ZERO + DO 20 J = 1, N + DO 10 I = 1, M + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 10 CONTINUE + 20 CONTINUE + ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN +* +* Find norm1(A). +* + VALUE = ZERO + DO 40 J = 1, N + SUM = ZERO + DO 30 I = 1, M + SUM = SUM + ABS( A( I, J ) ) + 30 CONTINUE + VALUE = MAX( VALUE, SUM ) + 40 CONTINUE + ELSE IF( LSAME( NORM, 'I' ) ) THEN +* +* Find normI(A). +* + DO 50 I = 1, M + WORK( I ) = ZERO + 50 CONTINUE + DO 70 J = 1, N + DO 60 I = 1, M + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) + 60 CONTINUE + 70 CONTINUE + VALUE = ZERO + DO 80 I = 1, M + VALUE = MAX( VALUE, WORK( I ) ) + 80 CONTINUE + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + DO 90 J = 1, N + CALL ZLASSQ( M, A( 1, J ), 1, SCALE, SUM ) + 90 CONTINUE + VALUE = SCALE*SQRT( SUM ) + END IF +* + ZLANGE = VALUE + RETURN +* +* End of ZLANGE +* + END diff --git a/2.3-1/src/fortran/lapack/zlanhe.f b/2.3-1/src/fortran/lapack/zlanhe.f new file mode 100644 index 00000000..86e57fcd --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlanhe.f @@ -0,0 +1,187 @@ + DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER NORM, UPLO + INTEGER LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION WORK( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, SQRT +* .. +* .. Executable Statements .. +* + IF( N.EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, J - 1 + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 10 CONTINUE + VALUE = MAX( VALUE, ABS( DBLE( A( J, J ) ) ) ) + 20 CONTINUE + ELSE + DO 40 J = 1, N + VALUE = MAX( VALUE, ABS( DBLE( A( J, J ) ) ) ) + DO 30 I = J + 1, N + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. + $ ( NORM.EQ.'1' ) ) THEN +* +* Find normI(A) ( = norm1(A), since A is hermitian). +* + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 60 J = 1, N + SUM = ZERO + DO 50 I = 1, J - 1 + ABSA = ABS( A( I, J ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + 50 CONTINUE + WORK( J ) = SUM + ABS( DBLE( A( J, J ) ) ) + 60 CONTINUE + DO 70 I = 1, N + VALUE = MAX( VALUE, WORK( I ) ) + 70 CONTINUE + ELSE + DO 80 I = 1, N + WORK( I ) = ZERO + 80 CONTINUE + DO 100 J = 1, N + SUM = WORK( J ) + ABS( DBLE( A( J, J ) ) ) + DO 90 I = J + 1, N + ABSA = ABS( A( I, J ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + 90 CONTINUE + VALUE = MAX( VALUE, SUM ) + 100 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + IF( LSAME( UPLO, 'U' ) ) THEN + DO 110 J = 2, N + CALL ZLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) + 110 CONTINUE + ELSE + DO 120 J = 1, N - 1 + CALL ZLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) + 120 CONTINUE + END IF + SUM = 2*SUM + DO 130 I = 1, N + IF( DBLE( A( I, I ) ).NE.ZERO ) THEN + ABSA = ABS( DBLE( A( I, I ) ) ) + IF( SCALE.LT.ABSA ) THEN + SUM = ONE + SUM*( SCALE / ABSA )**2 + SCALE = ABSA + ELSE + SUM = SUM + ( ABSA / SCALE )**2 + END IF + END IF + 130 CONTINUE + VALUE = SCALE*SQRT( SUM ) + END IF +* + ZLANHE = VALUE + RETURN +* +* End of ZLANHE +* + END diff --git a/2.3-1/src/fortran/lapack/zlanhs.f b/2.3-1/src/fortran/lapack/zlanhs.f new file mode 100644 index 00000000..d7b187a5 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlanhs.f @@ -0,0 +1,142 @@ + DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION WORK( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION SCALE, SUM, VALUE +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + IF( N.EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + VALUE = ZERO + DO 20 J = 1, N + DO 10 I = 1, MIN( N, J+1 ) + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 10 CONTINUE + 20 CONTINUE + ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN +* +* Find norm1(A). +* + VALUE = ZERO + DO 40 J = 1, N + SUM = ZERO + DO 30 I = 1, MIN( N, J+1 ) + SUM = SUM + ABS( A( I, J ) ) + 30 CONTINUE + VALUE = MAX( VALUE, SUM ) + 40 CONTINUE + ELSE IF( LSAME( NORM, 'I' ) ) THEN +* +* Find normI(A). +* + DO 50 I = 1, N + WORK( I ) = ZERO + 50 CONTINUE + DO 70 J = 1, N + DO 60 I = 1, MIN( N, J+1 ) + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) + 60 CONTINUE + 70 CONTINUE + VALUE = ZERO + DO 80 I = 1, N + VALUE = MAX( VALUE, WORK( I ) ) + 80 CONTINUE + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + DO 90 J = 1, N + CALL ZLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) + 90 CONTINUE + VALUE = SCALE*SQRT( SUM ) + END IF +* + ZLANHS = VALUE + RETURN +* +* End of ZLANHS +* + END diff --git a/2.3-1/src/fortran/lapack/zlaqp2.f b/2.3-1/src/fortran/lapack/zlaqp2.f new file mode 100644 index 00000000..46f6d95c --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlaqp2.f @@ -0,0 +1,179 @@ + SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, + $ WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER LDA, M, N, OFFSET +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION VN1( * ), VN2( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + COMPLEX*16 CONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, MN, OFFPI, PVT + DOUBLE PRECISION TEMP, TEMP2, TOL3Z + COMPLEX*16 AII +* .. +* .. External Subroutines .. + EXTERNAL ZLARF, ZLARFG, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DCONJG, MAX, MIN, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL IDAMAX, DLAMCH, DZNRM2 +* .. +* .. Executable Statements .. +* + MN = MIN( M-OFFSET, N ) + TOL3Z = SQRT(DLAMCH('Epsilon')) +* +* Compute factorization. +* + DO 20 I = 1, MN +* + OFFPI = OFFSET + I +* +* Determine ith pivot column and swap if necessary. +* + PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 ) +* + IF( PVT.NE.I ) THEN + CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( I ) + JPVT( I ) = ITEMP + VN1( PVT ) = VN1( I ) + VN2( PVT ) = VN2( I ) + END IF +* +* Generate elementary reflector H(i). +* + IF( OFFPI.LT.M ) THEN + CALL ZLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, + $ TAU( I ) ) + ELSE + CALL ZLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) + END IF +* + IF( I.LT.N ) THEN +* +* Apply H(i)' to A(offset+i:m,i+1:n) from the left. +* + AII = A( OFFPI, I ) + A( OFFPI, I ) = CONE + CALL ZLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, + $ DCONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA, + $ WORK( 1 ) ) + A( OFFPI, I ) = AII + END IF +* +* Update partial column norms. +* + DO 10 J = I + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following 4 lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN + IF( OFFPI.LT.M ) THEN + VN1( J ) = DZNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) + VN2( J ) = VN1( J ) + ELSE + VN1( J ) = ZERO + VN2( J ) = ZERO + END IF + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + 10 CONTINUE +* + 20 CONTINUE +* + RETURN +* +* End of ZLAQP2 +* + END diff --git a/2.3-1/src/fortran/lapack/zlaqps.f b/2.3-1/src/fortran/lapack/zlaqps.f new file mode 100644 index 00000000..40414503 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlaqps.f @@ -0,0 +1,266 @@ + SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, + $ VN2, AUXV, F, LDF ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER KB, LDA, LDF, M, N, NB, OFFSET +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION VN1( * ), VN2( * ) + COMPLEX*16 A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + COMPLEX*16 CZERO, CONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, + $ CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK + DOUBLE PRECISION TEMP, TEMP2, TOL3Z + COMPLEX*16 AKK +* .. +* .. External Subroutines .. + EXTERNAL ZGEMM, ZGEMV, ZLARFG, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, MAX, MIN, NINT, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL IDAMAX, DLAMCH, DZNRM2 +* .. +* .. Executable Statements .. +* + LASTRK = MIN( M, N+OFFSET ) + LSTICC = 0 + K = 0 + TOL3Z = SQRT(DLAMCH('Epsilon')) +* +* Beginning of while loop. +* + 10 CONTINUE + IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN + K = K + 1 + RK = OFFSET + K +* +* Determine ith pivot column and swap if necessary +* + PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) + IF( PVT.NE.K ) THEN + CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 ) + CALL ZSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( K ) + JPVT( K ) = ITEMP + VN1( PVT ) = VN1( K ) + VN2( PVT ) = VN2( K ) + END IF +* +* 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.GT.1 ) THEN + DO 20 J = 1, K - 1 + F( K, J ) = DCONJG( F( K, J ) ) + 20 CONTINUE + CALL ZGEMV( 'No transpose', M-RK+1, K-1, -CONE, A( RK, 1 ), + $ LDA, F( K, 1 ), LDF, CONE, A( RK, K ), 1 ) + DO 30 J = 1, K - 1 + F( K, J ) = DCONJG( F( K, J ) ) + 30 CONTINUE + END IF +* +* Generate elementary reflector H(k). +* + IF( RK.LT.M ) THEN + CALL ZLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) + ELSE + CALL ZLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) + END IF +* + AKK = A( RK, K ) + A( RK, K ) = CONE +* +* 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.LT.N ) THEN + CALL ZGEMV( 'Conjugate transpose', M-RK+1, N-K, TAU( K ), + $ A( RK, K+1 ), LDA, A( RK, K ), 1, CZERO, + $ F( K+1, K ), 1 ) + END IF +* +* Padding F(1:K,K) with zeros. +* + DO 40 J = 1, K + F( J, K ) = CZERO + 40 CONTINUE +* +* 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.GT.1 ) THEN + CALL ZGEMV( 'Conjugate transpose', M-RK+1, K-1, -TAU( K ), + $ A( RK, 1 ), LDA, A( RK, K ), 1, CZERO, + $ AUXV( 1 ), 1 ) +* + CALL ZGEMV( 'No transpose', N, K-1, CONE, F( 1, 1 ), LDF, + $ AUXV( 1 ), 1, CONE, F( 1, K ), 1 ) + END IF +* +* 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.LT.N ) THEN + CALL ZGEMM( 'No transpose', 'Conjugate transpose', 1, N-K, + $ K, -CONE, A( RK, 1 ), LDA, F( K+1, 1 ), LDF, + $ CONE, A( RK, K+1 ), LDA ) + END IF +* +* Update partial column norms. +* + IF( RK.LT.LASTRK ) THEN + DO 50 J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following 4 lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ABS( A( RK, J ) ) / VN1( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN + VN2( J ) = DBLE( LSTICC ) + LSTICC = J + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + 50 CONTINUE + END IF +* + A( RK, K ) = AKK +* +* End of while loop. +* + GO TO 10 + END IF + 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)'. +* + IF( KB.LT.MIN( N, M-OFFSET ) ) THEN + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-RK, N-KB, + $ KB, -CONE, A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, + $ CONE, A( RK+1, KB+1 ), LDA ) + END IF +* +* Recomputation of difficult columns. +* + 60 CONTINUE + IF( LSTICC.GT.0 ) THEN + ITEMP = NINT( VN2( LSTICC ) ) + VN1( LSTICC ) = DZNRM2( M-RK, A( RK+1, LSTICC ), 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 + GO TO 60 + END IF +* + RETURN +* +* End of ZLAQPS +* + END diff --git a/2.3-1/src/fortran/lapack/zlaqr0.f b/2.3-1/src/fortran/lapack/zlaqr0.f new file mode 100644 index 00000000..2a35a725 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlaqr0.f @@ -0,0 +1,601 @@ + SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* 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 increasing 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. ==== +* + INTEGER NTINY + PARAMETER ( NTINY = 11 ) + INTEGER KEXNW, KEXSH + PARAMETER ( KEXNW = 5, KEXSH = 6 ) + DOUBLE PRECISION WILK1 + PARAMETER ( WILK1 = 0.75d0 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 + DOUBLE PRECISION S + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, + $ NSR, NVE, NW, NWMAX, NWR + LOGICAL NWINC, SORTED + CHARACTER JBCMPZ*2 +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Local Arrays .. + COMPLEX*16 ZDUM( 1, 1 ) +* .. +* .. External Subroutines .. + EXTERNAL ZLACPY, ZLAHQR, ZLAQR3, ZLAQR4, ZLAQR5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, + $ SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. + INFO = 0 +* +* ==== Quick return for N = 0: nothing to do. ==== +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* +* ==== Tiny matrices must use ZLAHQR. ==== +* + IF( N.LE.NTINY ) THEN +* +* ==== Estimate optimal workspace. ==== +* + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, INFO ) + ELSE +* +* ==== Use small bulge multi-shift QR with aggressive early +* . deflation on larger-than-tiny matrices. ==== +* +* ==== Hope for the best. ==== +* + INFO = 0 +* +* ==== 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( 13, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) + NW = NWR +* +* ==== NSR = recommended number of simultaneous shifts. +* . At this point N .GT. NTINY = 11, so there is at +* . enough subdiagonal workspace for NSR to be even +* . and greater than or equal to two as required. ==== +* + NSR = ILAENV( 15, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) +* +* ==== Estimate optimal workspace ==== +* +* ==== Workspace query call to ZLAQR3 ==== +* + CALL ZLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, + $ LDH, WORK, -1 ) +* +* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR3) ==== +* + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== ZLAHQR/ZLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== Nibble crossover point ==== +* + NIBBLE = ILAENV( 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( 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. ==== +* + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) +* +* ==== NSMAX = the Largest number of simultaneous shifts +* . for which there is sufficient workspace. ==== +* + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) +* +* ==== NDFL: an iteration count restarted at deflation. ==== +* + NDFL = 1 +* +* ==== ITMAX = iteration limit ==== +* + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) +* +* ==== Last row and column in the active block ==== +* + KBOT = IHI +* +* ==== Main Loop ==== +* + DO 70 IT = 1, ITMAX +* +* ==== Done when KBOT falls below ILO ==== +* + IF( KBOT.LT.ILO ) + $ GO TO 80 +* +* ==== Locate active block ==== +* + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K +* +* ==== Select deflation window size ==== +* + NH = KBOT - KTOP + 1 + IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN +* +* ==== Typical deflation window. If possible and +* . advisable, nibble the entire active block. +* . If not, use size NWR or NWR+1 depending upon +* . which has the smaller corresponding subdiagonal +* . entry (a heuristic). ==== +* + NWINC = .TRUE. + IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN + NW = NH + ELSE + NW = MIN( NWR, NH, NWMAX ) + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. + $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + END IF + ELSE +* +* ==== Exceptional deflation window. If there have +* . been no deflations in KEXNW or more iterations, +* . then vary the deflation window size. At first, +* . because, larger windows are, in general, more +* . powerful than smaller ones, rapidly increase the +* . window up to the maximum reasonable and possible. +* . Then maybe try a slightly smaller window. ==== +* + IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN + NW = MIN( NWMAX, NH, 2*NW ) + ELSE + NWINC = .FALSE. + IF( NW.EQ.NH .AND. NH.GT.2 ) + $ NW = NH - 1 + END IF + END IF +* +* ==== 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 ==== +* + CALL ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, + $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, + $ LWORK ) +* +* ==== Adjust KBOT accounting for new deflations. ==== +* + KBOT = 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.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN +* +* ==== NS = nominal number of simultaneous shifts. +* . This may be lowered (slightly) if ZLAQR3 +* . did not provide that many shifts. ==== +* + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( 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( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, KS + 1, -2 + W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) + W( I-1 ) = W( I ) + 30 CONTINUE + 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.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + IF( NS.GT.NMIN ) THEN + CALL ZLAQR4( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, W( KS ), 1, 1, + $ ZDUM, 1, WORK, LWORK, INF ) + ELSE + CALL ZLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, W( KS ), 1, 1, + $ ZDUM, 1, INF ) + END IF + KS = 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.GE.KBOT ) THEN + S = CABS1( H( KBOT-1, KBOT-1 ) ) + + $ CABS1( H( KBOT, KBOT-1 ) ) + + $ CABS1( H( KBOT-1, KBOT ) ) + + $ CABS1( H( KBOT, KBOT ) ) + AA = H( KBOT-1, KBOT-1 ) / S + CC = H( KBOT, KBOT-1 ) / S + BB = H( KBOT-1, KBOT ) / S + DD = H( KBOT, KBOT ) / S + TR2 = ( AA+DD ) / TWO + DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC + RTDISC = SQRT( -DET ) + W( KBOT-1 ) = ( TR2+RTDISC )*S + W( KBOT ) = ( TR2-RTDISC )*S +* + KS = KBOT - 1 + END IF + END IF +* + IF( KBOT-KS+1.GT.NS ) THEN +* +* ==== Sort the shifts (Helps a little) ==== +* + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) + $ THEN + SORTED = .false. + SWAP = W( I ) + W( I ) = W( I+1 ) + W( I+1 ) = SWAP + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF + END IF +* +* ==== If there are only two shifts, then use +* . only one. ==== +* + IF( KBOT-KS+1.EQ.2 ) THEN + IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. + $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + W( KBOT-1 ) = W( KBOT ) + ELSE + W( KBOT ) = W( KBOT-1 ) + END IF + END IF +* +* ==== 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. ==== +* + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( 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 = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 +* +* ==== Small-bulge multi-shift QR sweep ==== +* + CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, + $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, + $ NHO, H( KU, KWH ), LDH ) + END IF +* +* ==== Note progress (or the lack of it). ==== +* + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF +* +* ==== End of main loop ==== + 70 CONTINUE +* +* ==== Iteration limit exceeded. Set INFO to show where +* . the problem occurred and exit. ==== +* + INFO = KBOT + 80 CONTINUE + END IF +* +* ==== Return the optimal value of LWORK. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR0 ==== +* + END diff --git a/2.3-1/src/fortran/lapack/zlaqr1.f b/2.3-1/src/fortran/lapack/zlaqr1.f new file mode 100644 index 00000000..b8c1c3d4 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlaqr1.f @@ -0,0 +1,97 @@ + SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + COMPLEX*16 S1, S2 + INTEGER LDH, N +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), V( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 CDUM + DOUBLE PRECISION H21S, H31S, S +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. + IF( N.EQ.2 ) THEN + S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) + IF( S.EQ.RZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-S1 )* + $ ( ( H( 1, 1 )-S2 ) / S ) + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + END IF + ELSE + S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) + + $ CABS1( H( 3, 1 ) ) + IF( S.EQ.ZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + V( 3 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + H31S = H( 3, 1 ) / S + V( 1 ) = ( H( 1, 1 )-S1 )*( ( H( 1, 1 )-S2 ) / S ) + + $ H( 1, 2 )*H21S + H( 1, 3 )*H31S + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + H( 2, 3 )*H31S + V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-S1-S2 ) + H21S*H( 3, 2 ) + END IF + END IF + END diff --git a/2.3-1/src/fortran/lapack/zlaqr2.f b/2.3-1/src/fortran/lapack/zlaqr2.f new file mode 100644 index 00000000..0add51ae --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlaqr2.f @@ -0,0 +1,437 @@ + SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, + $ NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), + $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* 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,IHI) +* 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 .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 BETA, CDUM, S, TAU + DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, + $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, + $ ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNGHR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to ZGEHRD ==== +* + CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to ZUNGHR ==== +* + CALL ZUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = JW + MAX( LWK1, LWK2 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SH( KWTOP ) = H( KWTOP, KWTOP ) + NS = 1 + ND = 0 + IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, + $ KWTOP ) ) ) ) THEN + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) +* + CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + $ JW, V, LDV, INFQR ) +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + DO 10 KNT = INFQR + 1, JW +* +* ==== Small spike tip deflation test ==== +* + FOO = CABS1( T( NS, NS ) ) + IF( FOO.EQ.RZERO ) + $ FOO = CABS1( S ) + IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) + $ THEN +* +* ==== One more converged eigenvalue ==== +* + NS = NS - 1 + ELSE +* +* ==== One undflatable eigenvalue. Move it up out of the +* . way. (ZTREXC can not fail in this case.) ==== +* + IFST = NS + CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + ILST = ILST + 1 + END IF + 10 CONTINUE +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting the diagonal of T improves accuracy for +* . graded matrices. ==== +* + DO 30 I = INFQR + 1, NS + IFST = I + DO 20 J = I + 1, NS + IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) + $ IFST = J + 20 CONTINUE + ILST = I + IF( IFST.NE.ILST ) + $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + 30 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + DO 40 I = INFQR + 1, JW + SH( KWTOP+I-1 ) = T( I, I ) + 40 CONTINUE +* +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL ZCOPY( NS, V, LDV, WORK, 1 ) + DO 50 I = 1, NS + WORK( I ) = DCONJG( WORK( I ) ) + 50 CONTINUE + BETA = WORK( 1 ) + CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE +* + CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) +* + CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) + CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. (A modified version +* . of ZUNGHR that accumulates block Householder +* . transformations into V directly might be +* . marginally more efficient than the following.) ==== +* + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN + CALL ZUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + CALL ZGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, + $ WV, LDWV ) + CALL ZLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) + END IF +* +* ==== Update vertical slab in H ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 60 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 60 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 70 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 70 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 80 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 80 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR2 ==== +* + END diff --git a/2.3-1/src/fortran/lapack/zlaqr3.f b/2.3-1/src/fortran/lapack/zlaqr3.f new file mode 100644 index 00000000..e9bf393a --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlaqr3.f @@ -0,0 +1,448 @@ + SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, + $ NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), + $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* ****************************************************************** +* 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,IHI) +* 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 .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 BETA, CDUM, S, TAU + DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, + $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, + $ LWKOPT, NMIN +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + EXTERNAL DLAMCH, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, + $ ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNGHR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to ZGEHRD ==== +* + CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to ZUNGHR ==== +* + CALL ZUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to ZLAQR4 ==== +* + CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V, + $ LDV, WORK, -1, INFQR ) + LWK3 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SH( KWTOP ) = H( KWTOP, KWTOP ) + NS = 1 + ND = 0 + IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, + $ KWTOP ) ) ) ) THEN + + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) +* + CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + NMIN = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK ) + IF( JW.GT.NMIN ) THEN + CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + $ JW, V, LDV, WORK, LWORK, INFQR ) + ELSE + CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + $ JW, V, LDV, INFQR ) + END IF +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + DO 10 KNT = INFQR + 1, JW +* +* ==== Small spike tip deflation test ==== +* + FOO = CABS1( T( NS, NS ) ) + IF( FOO.EQ.RZERO ) + $ FOO = CABS1( S ) + IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) + $ THEN +* +* ==== One more converged eigenvalue ==== +* + NS = NS - 1 + ELSE +* +* ==== One undflatable eigenvalue. Move it up out of the +* . way. (ZTREXC can not fail in this case.) ==== +* + IFST = NS + CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + ILST = ILST + 1 + END IF + 10 CONTINUE +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting the diagonal of T improves accuracy for +* . graded matrices. ==== +* + DO 30 I = INFQR + 1, NS + IFST = I + DO 20 J = I + 1, NS + IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) + $ IFST = J + 20 CONTINUE + ILST = I + IF( IFST.NE.ILST ) + $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + 30 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + DO 40 I = INFQR + 1, JW + SH( KWTOP+I-1 ) = T( I, I ) + 40 CONTINUE +* +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL ZCOPY( NS, V, LDV, WORK, 1 ) + DO 50 I = 1, NS + WORK( I ) = DCONJG( WORK( I ) ) + 50 CONTINUE + BETA = WORK( 1 ) + CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE +* + CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) +* + CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) + CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. (A modified version +* . of ZUNGHR that accumulates block Householder +* . transformations into V directly might be +* . marginally more efficient than the following.) ==== +* + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN + CALL ZUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + CALL ZGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, + $ WV, LDWV ) + CALL ZLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) + END IF +* +* ==== Update vertical slab in H ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 60 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 60 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 70 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 70 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 80 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 80 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR3 ==== +* + END diff --git a/2.3-1/src/fortran/lapack/zlaqr4.f b/2.3-1/src/fortran/lapack/zlaqr4.f new file mode 100644 index 00000000..eef7f00a --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlaqr4.f @@ -0,0 +1,602 @@ + SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* 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 increasing 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. ==== +* + INTEGER NTINY + PARAMETER ( NTINY = 11 ) + INTEGER KEXNW, KEXSH + PARAMETER ( KEXNW = 5, KEXSH = 6 ) + DOUBLE PRECISION WILK1 + PARAMETER ( WILK1 = 0.75d0 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 + DOUBLE PRECISION S + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, + $ NSR, NVE, NW, NWMAX, NWR + LOGICAL NWINC, SORTED + CHARACTER JBCMPZ*2 +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Local Arrays .. + COMPLEX*16 ZDUM( 1, 1 ) +* .. +* .. External Subroutines .. + EXTERNAL ZLACPY, ZLAHQR, ZLAQR2, ZLAQR5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, + $ SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. + INFO = 0 +* +* ==== Quick return for N = 0: nothing to do. ==== +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* +* ==== Tiny matrices must use ZLAHQR. ==== +* + IF( N.LE.NTINY ) THEN +* +* ==== Estimate optimal workspace. ==== +* + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, INFO ) + ELSE +* +* ==== Use small bulge multi-shift QR with aggressive early +* . deflation on larger-than-tiny matrices. ==== +* +* ==== Hope for the best. ==== +* + INFO = 0 +* +* ==== 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( 13, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) + NW = NWR +* +* ==== NSR = recommended number of simultaneous shifts. +* . At this point N .GT. NTINY = 11, so there is at +* . enough subdiagonal workspace for NSR to be even +* . and greater than or equal to two as required. ==== +* + NSR = ILAENV( 15, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) +* +* ==== Estimate optimal workspace ==== +* +* ==== Workspace query call to ZLAQR2 ==== +* + CALL ZLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, + $ LDH, WORK, -1 ) +* +* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ==== +* + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== ZLAHQR/ZLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== Nibble crossover point ==== +* + NIBBLE = ILAENV( 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( 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. ==== +* + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) +* +* ==== NSMAX = the Largest number of simultaneous shifts +* . for which there is sufficient workspace. ==== +* + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) +* +* ==== NDFL: an iteration count restarted at deflation. ==== +* + NDFL = 1 +* +* ==== ITMAX = iteration limit ==== +* + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) +* +* ==== Last row and column in the active block ==== +* + KBOT = IHI +* +* ==== Main Loop ==== +* + DO 70 IT = 1, ITMAX +* +* ==== Done when KBOT falls below ILO ==== +* + IF( KBOT.LT.ILO ) + $ GO TO 80 +* +* ==== Locate active block ==== +* + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K +* +* ==== Select deflation window size ==== +* + NH = KBOT - KTOP + 1 + IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN +* +* ==== Typical deflation window. If possible and +* . advisable, nibble the entire active block. +* . If not, use size NWR or NWR+1 depending upon +* . which has the smaller corresponding subdiagonal +* . entry (a heuristic). ==== +* + NWINC = .TRUE. + IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN + NW = NH + ELSE + NW = MIN( NWR, NH, NWMAX ) + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. + $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + END IF + ELSE +* +* ==== Exceptional deflation window. If there have +* . been no deflations in KEXNW or more iterations, +* . then vary the deflation window size. At first, +* . because, larger windows are, in general, more +* . powerful than smaller ones, rapidly increase the +* . window up to the maximum reasonable and possible. +* . Then maybe try a slightly smaller window. ==== +* + IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN + NW = MIN( NWMAX, NH, 2*NW ) + ELSE + NWINC = .FALSE. + IF( NW.EQ.NH .AND. NH.GT.2 ) + $ NW = NH - 1 + END IF + END IF +* +* ==== 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 ==== +* + CALL ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, + $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, + $ LWORK ) +* +* ==== Adjust KBOT accounting for new deflations. ==== +* + KBOT = 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.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN +* +* ==== NS = nominal number of simultaneous shifts. +* . This may be lowered (slightly) if ZLAQR2 +* . did not provide that many shifts. ==== +* + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( 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( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, KS + 1, -2 + W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) + W( I-1 ) = W( I ) + 30 CONTINUE + 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.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + CALL ZLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, W( KS ), 1, 1, ZDUM, + $ 1, INF ) + KS = 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.GE.KBOT ) THEN + S = CABS1( H( KBOT-1, KBOT-1 ) ) + + $ CABS1( H( KBOT, KBOT-1 ) ) + + $ CABS1( H( KBOT-1, KBOT ) ) + + $ CABS1( H( KBOT, KBOT ) ) + AA = H( KBOT-1, KBOT-1 ) / S + CC = H( KBOT, KBOT-1 ) / S + BB = H( KBOT-1, KBOT ) / S + DD = H( KBOT, KBOT ) / S + TR2 = ( AA+DD ) / TWO + DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC + RTDISC = SQRT( -DET ) + W( KBOT-1 ) = ( TR2+RTDISC )*S + W( KBOT ) = ( TR2-RTDISC )*S +* + KS = KBOT - 1 + END IF + END IF +* + IF( KBOT-KS+1.GT.NS ) THEN +* +* ==== Sort the shifts (Helps a little) ==== +* + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) + $ THEN + SORTED = .false. + SWAP = W( I ) + W( I ) = W( I+1 ) + W( I+1 ) = SWAP + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF + END IF +* +* ==== If there are only two shifts, then use +* . only one. ==== +* + IF( KBOT-KS+1.EQ.2 ) THEN + IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. + $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + W( KBOT-1 ) = W( KBOT ) + ELSE + W( KBOT ) = W( KBOT-1 ) + END IF + END IF +* +* ==== 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. ==== +* + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( 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 = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 +* +* ==== Small-bulge multi-shift QR sweep ==== +* + CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, + $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, + $ NHO, H( KU, KWH ), LDH ) + END IF +* +* ==== Note progress (or the lack of it). ==== +* + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF +* +* ==== End of main loop ==== + 70 CONTINUE +* +* ==== Iteration limit exceeded. Set INFO to show where +* . the problem occurred and exit. ==== +* + INFO = KBOT + 80 CONTINUE + END IF +* +* ==== Return the optimal value of LWORK. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR4 ==== +* + END diff --git a/2.3-1/src/fortran/lapack/zlaqr5.f b/2.3-1/src/fortran/lapack/zlaqr5.f new file mode 100644 index 00000000..fa8de7bb --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlaqr5.f @@ -0,0 +1,809 @@ + SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, + $ H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, + $ WV, LDWV, NH, WH, LDWH ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, + $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), + $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* 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) COMPLEX*16 array of size (NSHFTS) +* S contains the shifts of origin that define the multi- +* shift QR sweep. +* +* 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 .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 ALPHA, BETA, CDUM, REFSUM + DOUBLE PRECISION H11, H12, H21, H22, SAFMAX, SAFMIN, SCL, + $ SMLNUM, TST1, TST2, ULP + INTEGER I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, + $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, + $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, + $ NS, NU + LOGICAL ACCUM, BLK22, BMP22 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. +* + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD +* .. +* .. Local Arrays .. + COMPLEX*16 VT( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, ZGEMM, ZLACPY, ZLAQR1, ZLARFG, ZLASET, + $ ZTRMM +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* ==== If there are no shifts, then there is nothing to do. ==== +* + IF( NSHFTS.LT.2 ) + $ RETURN +* +* ==== If the active block is empty or 1-by-1, then there +* . is nothing to do. ==== +* + IF( KTOP.GE.KBOT ) + $ RETURN +* +* ==== NSHFTS is supposed to be even, but if is odd, +* . then simply reduce it by one. ==== +* + NS = NSHFTS - MOD( NSHFTS, 2 ) +* +* ==== Machine constants for deflation ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Use accumulated reflections to update far-from-diagonal +* . entries ? ==== +* + ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) +* +* ==== If so, exploit the 2-by-2 block structure? ==== +* + BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) +* +* ==== clear trash ==== +* + IF( KTOP+2.LE.KBOT ) + $ H( KTOP+2, KTOP ) = ZERO +* +* ==== NBMPS = number of 2-shift bulges in the chain ==== +* + NBMPS = NS / 2 +* +* ==== KDU = width of slab ==== +* + KDU = 6*NBMPS - 3 +* +* ==== Create and chase chains of NBMPS bulges ==== +* + DO 210 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 + NDCOL = INCOL + KDU + IF( ACCUM ) + $ CALL ZLASET( 'ALL', KDU, KDU, ZERO, ONE, U, 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.) ==== +* + DO 140 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) +* +* ==== 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. ==== +* + MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 ) + MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 ) + M22 = MBOT + 1 + BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ. + $ ( KBOT-2 ) +* +* ==== Generate reflections to chase the chain right +* . one column. (The minimum value of K is KTOP-1.) ==== +* + DO 10 M = MTOP, MBOT + K = KRCOL + 3*( M-1 ) + IF( K.EQ.KTOP-1 ) THEN + CALL ZLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ), + $ S( 2*M ), V( 1, M ) ) + ALPHA = V( 1, M ) + CALL ZLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) ) + ELSE + BETA = H( K+1, K ) + V( 2, M ) = H( K+2, K ) + V( 3, M ) = H( K+3, K ) + CALL ZLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) +* +* ==== A Bulge may collapse because of vigilant +* . deflation or destructive underflow. (The +* . initial bulge is always collapsed.) Use +* . the two-small-subdiagonals trick to try +* . to get it started again. If V(2,M).NE.0 and +* . V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then +* . this bulge is collapsing into a zero +* . subdiagonal. It will be restarted next +* . trip through the loop.) +* + IF( V( 1, M ).NE.ZERO .AND. + $ ( V( 3, M ).NE.ZERO .OR. ( H( K+3, + $ K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) ) + $ THEN +* +* ==== Typical case: not collapsed (yet). ==== +* + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + ELSE +* +* ==== Atypical case: collapsed. Attempt to +* . reintroduce ignoring H(K+1,K). If the +* . fill resulting from the new reflector +* . is too large, then abandon it. +* . Otherwise, use the new one. ==== +* + CALL ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ), + $ S( 2*M ), VT ) + SCL = CABS1( VT( 1 ) ) + CABS1( VT( 2 ) ) + + $ CABS1( VT( 3 ) ) + IF( SCL.NE.RZERO ) THEN + VT( 1 ) = VT( 1 ) / SCL + VT( 2 ) = VT( 2 ) / SCL + VT( 3 ) = VT( 3 ) / SCL + END IF +* +* ==== The following is the traditional and +* . conservative two-small-subdiagonals +* . test. ==== +* . + IF( CABS1( H( K+1, K ) )* + $ ( CABS1( VT( 2 ) )+CABS1( VT( 3 ) ) ).GT.ULP* + $ CABS1( VT( 1 ) )*( CABS1( H( K, + $ K ) )+CABS1( H( K+1, K+1 ) )+CABS1( H( K+2, + $ K+2 ) ) ) ) THEN +* +* ==== Starting a new bulge here would +* . create non-negligible fill. If +* . the old reflector is diagonal (only +* . possible with underflows), then +* . change it to I. Otherwise, use +* . it with trepidation. ==== +* + IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO ) + $ THEN + V( 1, M ) = ZERO + ELSE + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + END IF + ELSE +* +* ==== Stating a new bulge here would +* . create only negligible fill. +* . Replace the old reflector with +* . the new one. ==== +* + ALPHA = VT( 1 ) + CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) + REFSUM = H( K+1, K ) + + $ H( K+2, K )*DCONJG( VT( 2 ) ) + + $ H( K+3, K )*DCONJG( VT( 3 ) ) + H( K+1, K ) = H( K+1, K ) - + $ DCONJG( VT( 1 ) )*REFSUM + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + V( 1, M ) = VT( 1 ) + V( 2, M ) = VT( 2 ) + V( 3, M ) = VT( 3 ) + END IF + END IF + END IF + 10 CONTINUE +* +* ==== Generate a 2-by-2 reflection, if needed. ==== +* + K = KRCOL + 3*( M22-1 ) + IF( BMP22 ) THEN + IF( K.EQ.KTOP-1 ) THEN + CALL ZLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ), + $ S( 2*M22 ), V( 1, M22 ) ) + BETA = V( 1, M22 ) + CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) + ELSE + BETA = H( K+1, K ) + V( 2, M22 ) = H( K+2, K ) + CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + END IF + ELSE +* +* ==== Initialize V(1,M22) here to avoid possible undefined +* . variable problems later. ==== +* + V( 1, M22 ) = ZERO + END IF +* +* ==== Multiply H by reflections from the left ==== +* + IF( ACCUM ) THEN + JBOT = MIN( NDCOL, KBOT ) + ELSE IF( WANTT ) THEN + JBOT = N + ELSE + JBOT = KBOT + END IF + DO 30 J = MAX( KTOP, KRCOL ), JBOT + MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) + DO 20 M = MTOP, MEND + K = KRCOL + 3*( M-1 ) + REFSUM = DCONJG( V( 1, M ) )* + $ ( H( K+1, J )+DCONJG( V( 2, M ) )* + $ H( K+2, J )+DCONJG( V( 3, M ) )*H( K+3, J ) ) + H( K+1, J ) = H( K+1, J ) - REFSUM + H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M ) + H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M ) + 20 CONTINUE + 30 CONTINUE + IF( BMP22 ) THEN + K = KRCOL + 3*( M22-1 ) + DO 40 J = MAX( K+1, KTOP ), JBOT + REFSUM = DCONJG( V( 1, M22 ) )* + $ ( H( K+1, J )+DCONJG( V( 2, M22 ) )* + $ H( K+2, J ) ) + H( K+1, J ) = H( K+1, J ) - REFSUM + H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 ) + 40 CONTINUE + END IF +* +* ==== Multiply H by reflections from the right. +* . Delay filling in the last row until the +* . vigilant deflation check is complete. ==== +* + IF( ACCUM ) THEN + JTOP = MAX( KTOP, INCOL ) + ELSE IF( WANTT ) THEN + JTOP = 1 + ELSE + JTOP = KTOP + END IF + DO 80 M = MTOP, MBOT + IF( V( 1, M ).NE.ZERO ) THEN + K = KRCOL + 3*( M-1 ) + DO 50 J = JTOP, MIN( KBOT, K+3 ) + REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* + $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) ) + H( J, K+1 ) = H( J, K+1 ) - REFSUM + H( J, K+2 ) = H( J, K+2 ) - + $ REFSUM*DCONJG( V( 2, M ) ) + H( J, K+3 ) = H( J, K+3 ) - + $ REFSUM*DCONJG( V( 3, M ) ) + 50 CONTINUE +* + IF( ACCUM ) THEN +* +* ==== Accumulate U. (If necessary, update Z later +* . with with an efficient matrix-matrix +* . multiply.) ==== +* + KMS = K - INCOL + DO 60 J = MAX( 1, KTOP-INCOL ), KDU + REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* + $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) ) + U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM + U( J, KMS+2 ) = U( J, KMS+2 ) - + $ REFSUM*DCONJG( V( 2, M ) ) + U( J, KMS+3 ) = U( J, KMS+3 ) - + $ REFSUM*DCONJG( V( 3, M ) ) + 60 CONTINUE + ELSE IF( WANTZ ) THEN +* +* ==== U is not accumulated, so update Z +* . now by multiplying by reflections +* . from the right. ==== +* + DO 70 J = ILOZ, IHIZ + REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* + $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) ) + Z( J, K+1 ) = Z( J, K+1 ) - REFSUM + Z( J, K+2 ) = Z( J, K+2 ) - + $ REFSUM*DCONJG( V( 2, M ) ) + Z( J, K+3 ) = Z( J, K+3 ) - + $ REFSUM*DCONJG( V( 3, M ) ) + 70 CONTINUE + END IF + END IF + 80 CONTINUE +* +* ==== Special case: 2-by-2 reflection (if needed) ==== +* + K = KRCOL + 3*( M22-1 ) + IF( BMP22 .AND. ( V( 1, M22 ).NE.ZERO ) ) THEN + DO 90 J = JTOP, MIN( KBOT, K+3 ) + REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* + $ H( J, K+2 ) ) + H( J, K+1 ) = H( J, K+1 ) - REFSUM + H( J, K+2 ) = H( J, K+2 ) - + $ REFSUM*DCONJG( V( 2, M22 ) ) + 90 CONTINUE +* + IF( ACCUM ) THEN + KMS = K - INCOL + DO 100 J = MAX( 1, KTOP-INCOL ), KDU + REFSUM = V( 1, M22 )*( U( J, KMS+1 )+V( 2, M22 )* + $ U( J, KMS+2 ) ) + U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM + U( J, KMS+2 ) = U( J, KMS+2 ) - + $ REFSUM*DCONJG( V( 2, M22 ) ) + 100 CONTINUE + ELSE IF( WANTZ ) THEN + DO 110 J = ILOZ, IHIZ + REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* + $ Z( J, K+2 ) ) + Z( J, K+1 ) = Z( J, K+1 ) - REFSUM + Z( J, K+2 ) = Z( J, K+2 ) - + $ REFSUM*DCONJG( V( 2, M22 ) ) + 110 CONTINUE + END IF + END IF +* +* ==== Vigilant deflation check ==== +* + MSTART = MTOP + IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) + $ MSTART = MSTART + 1 + MEND = MBOT + IF( BMP22 ) + $ MEND = MEND + 1 + IF( KRCOL.EQ.KBOT-2 ) + $ MEND = MEND + 1 + DO 120 M = MSTART, MEND + K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) +* +* ==== 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 ).NE.ZERO ) THEN + TST1 = CABS1( H( K, K ) ) + CABS1( H( K+1, K+1 ) ) + IF( TST1.EQ.RZERO ) THEN + IF( K.GE.KTOP+1 ) + $ TST1 = TST1 + CABS1( H( K, K-1 ) ) + IF( K.GE.KTOP+2 ) + $ TST1 = TST1 + CABS1( H( K, K-2 ) ) + IF( K.GE.KTOP+3 ) + $ TST1 = TST1 + CABS1( H( K, K-3 ) ) + IF( K.LE.KBOT-2 ) + $ TST1 = TST1 + CABS1( H( K+2, K+1 ) ) + IF( K.LE.KBOT-3 ) + $ TST1 = TST1 + CABS1( H( K+3, K+1 ) ) + IF( K.LE.KBOT-4 ) + $ TST1 = TST1 + CABS1( H( K+4, K+1 ) ) + END IF + IF( CABS1( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) + $ THEN + H12 = MAX( CABS1( H( K+1, K ) ), + $ CABS1( H( K, K+1 ) ) ) + H21 = MIN( CABS1( H( K+1, K ) ), + $ CABS1( H( K, K+1 ) ) ) + H11 = MAX( CABS1( H( K+1, K+1 ) ), + $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) + H22 = MIN( CABS1( H( K+1, K+1 ) ), + $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) + SCL = H11 + H12 + TST2 = H22*( H11 / SCL ) +* + IF( TST2.EQ.RZERO .OR. H21*( H12 / SCL ).LE. + $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO + END IF + END IF + 120 CONTINUE +* +* ==== Fill in the last row of each bulge. ==== +* + MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) + DO 130 M = MTOP, MEND + K = KRCOL + 3*( M-1 ) + REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 ) + H( K+4, K+1 ) = -REFSUM + H( K+4, K+2 ) = -REFSUM*DCONJG( V( 2, M ) ) + H( K+4, K+3 ) = H( K+4, K+3 ) - + $ REFSUM*DCONJG( V( 3, M ) ) + 130 CONTINUE +* +* ==== End of near-the-diagonal bulge chase. ==== +* + 140 CONTINUE +* +* ==== Use U (if accumulated) to update far-from-diagonal +* . entries in H. If required, use U to update Z as +* . well. ==== +* + IF( ACCUM ) THEN + IF( WANTT ) THEN + JTOP = 1 + JBOT = N + ELSE + JTOP = KTOP + JBOT = KBOT + END IF + IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. + $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN +* +* ==== 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. ==== +* + K1 = MAX( 1, KTOP-INCOL ) + NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 +* +* ==== Horizontal Multiply ==== +* + DO 150 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) + CALL ZGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), + $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, + $ LDWH ) + CALL ZLACPY( 'ALL', NU, JLEN, WH, LDWH, + $ H( INCOL+K1, JCOL ), LDH ) + 150 CONTINUE +* +* ==== Vertical multiply ==== +* + DO 160 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV + JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) + CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, + $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), + $ LDU, ZERO, WV, LDWV ) + CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, + $ H( JROW, INCOL+K1 ), LDH ) + 160 CONTINUE +* +* ==== Z multiply (also vertical) ==== +* + IF( WANTZ ) THEN + DO 170 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) + CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, + $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), + $ LDU, ZERO, WV, LDWV ) + CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, + $ Z( JROW, INCOL+K1 ), LDZ ) + 170 CONTINUE + END IF + 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 ==== +* + DO 180 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) +* +* ==== Copy bottom of H to top+KZS of scratch ==== +* (The first KZS rows get multiplied by zero.) ==== +* + CALL ZLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), + $ LDH, WH( KZS+1, 1 ), LDWH ) +* +* ==== Multiply by U21' ==== +* + CALL ZLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) + CALL ZTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, + $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), + $ LDWH ) +* +* ==== Multiply top of H by U11' ==== +* + CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, + $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) +* +* ==== Copy top of H bottom of WH ==== +* + CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, + $ WH( I2+1, 1 ), LDWH ) +* +* ==== Multiply by U21' ==== +* + CALL ZTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, + $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) +* +* ==== Multiply by U22 ==== +* + CALL ZGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, + $ U( J2+1, I2+1 ), LDU, + $ H( INCOL+1+J2, JCOL ), LDH, ONE, + $ WH( I2+1, 1 ), LDWH ) +* +* ==== Copy it back ==== +* + CALL ZLACPY( 'ALL', KDU, JLEN, WH, LDWH, + $ H( INCOL+1, JCOL ), LDH ) + 180 CONTINUE +* +* ==== Vertical multiply ==== +* + DO 190 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV + JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) +* +* ==== Copy right of H to scratch (the first KZS +* . columns get multiplied by zero) ==== +* + CALL ZLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), + $ LDH, WV( 1, 1+KZS ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) + CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, + $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), + $ LDWV ) +* +* ==== Multiply by U11 ==== +* + CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, + $ LDWV ) +* +* ==== Copy left of H to right of scratch ==== +* + CALL ZLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, + $ WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U22 ==== +* + CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, + $ H( JROW, INCOL+1+J2 ), LDH, + $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ), + $ LDWV ) +* +* ==== Copy it back ==== +* + CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ H( JROW, INCOL+1 ), LDH ) + 190 CONTINUE +* +* ==== Multiply Z (also vertical) ==== +* + IF( WANTZ ) THEN + DO 200 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) +* +* ==== Copy right of Z to left of scratch (first +* . KZS columns get multiplied by zero) ==== +* + CALL ZLACPY( 'ALL', JLEN, KNZ, + $ Z( JROW, INCOL+1+J2 ), LDZ, + $ WV( 1, 1+KZS ), LDWV ) +* +* ==== Multiply by U12 ==== +* + CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, + $ LDWV ) + CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, + $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), + $ LDWV ) +* +* ==== Multiply by U11 ==== +* + CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, + $ WV, LDWV ) +* +* ==== Copy left of Z to right of scratch ==== +* + CALL ZLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), + $ LDZ, WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), + $ LDWV ) +* +* ==== Multiply by U22 ==== +* + CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, + $ Z( JROW, INCOL+1+J2 ), LDZ, + $ U( J2+1, I2+1 ), LDU, ONE, + $ WV( 1, 1+I2 ), LDWV ) +* +* ==== Copy the result back to Z ==== +* + CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ Z( JROW, INCOL+1 ), LDZ ) + 200 CONTINUE + END IF + END IF + END IF + 210 CONTINUE +* +* ==== End of ZLAQR5 ==== +* + END diff --git a/2.3-1/src/fortran/lapack/zlarf.f b/2.3-1/src/fortran/lapack/zlarf.f new file mode 100644 index 00000000..d5233c8c --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlarf.f @@ -0,0 +1,120 @@ + SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + COMPLEX*16 TAU +* .. +* .. Array Arguments .. + COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. External Subroutines .. + EXTERNAL ZGEMV, ZGERC +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C +* + IF( TAU.NE.ZERO ) THEN +* +* w := C' * v +* + CALL ZGEMV( 'Conjugate transpose', M, N, ONE, C, LDC, V, + $ INCV, ZERO, WORK, 1 ) +* +* C := C - v * w' +* + CALL ZGERC( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) + END IF + ELSE +* +* Form C * H +* + IF( TAU.NE.ZERO ) THEN +* +* w := C * v +* + CALL ZGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, + $ ZERO, WORK, 1 ) +* +* C := C - w * v' +* + CALL ZGERC( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) + END IF + END IF + RETURN +* +* End of ZLARF +* + END diff --git a/2.3-1/src/fortran/lapack/zlarfb.f b/2.3-1/src/fortran/lapack/zlarfb.f new file mode 100644 index 00000000..af93ea58 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlarfb.f @@ -0,0 +1,608 @@ + SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, + $ T, LDT, C, LDC, WORK, LDWORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), + $ WORK( LDWORK, * ) +* .. +* +* 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 .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + CHARACTER TRANST + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* + IF( LSAME( TRANS, 'N' ) ) THEN + TRANST = 'C' + ELSE + TRANST = 'N' + END IF +* + IF( LSAME( STOREV, 'C' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 ) (first K rows) +* ( V2 ) +* where V1 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C where C = ( C1 ) +* ( C2 ) +* +* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) +* +* W := C1' +* + DO 10 J = 1, K + CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( N, WORK( 1, J ), 1 ) + 10 CONTINUE +* +* W := W * V1 +* + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C2'*V2 +* + CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, + $ K, M-K, ONE, C( K+1, 1 ), LDC, + $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T' or W * T +* + CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W' +* + IF( M.GT.K ) THEN +* +* C2 := C2 - V2 * W' +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK, + $ LDWORK, ONE, C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1' +* + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W' +* + DO 30 J = 1, K + DO 20 I = 1, N + C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C1 +* + DO 40 J = 1, K + CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) + 40 CONTINUE +* +* W := W * V1 +* + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C2 * V2 +* + CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T' +* + CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V' +* + IF( N.GT.K ) THEN +* +* C2 := C2 - W * V2' +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, + $ N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ), + $ LDV, ONE, C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1' +* + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 60 J = 1, K + DO 50 I = 1, M + C( I, J ) = C( I, J ) - WORK( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + ELSE +* +* Let V = ( V1 ) +* ( V2 ) (last K rows) +* where V2 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C where C = ( C1 ) +* ( C2 ) +* +* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) +* +* W := C2' +* + DO 70 J = 1, K + CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( N, WORK( 1, J ), 1 ) + 70 CONTINUE +* +* W := W * V2 +* + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C1'*V1 +* + CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, + $ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK, + $ LDWORK ) + END IF +* +* W := W * T' or W * T +* + CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W' +* + IF( M.GT.K ) THEN +* +* C1 := C1 - V1 * W' +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ M-K, N, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) + END IF +* +* W := W * V2' +* + CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', + $ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK, + $ LDWORK ) +* +* C2 := C2 - W' +* + DO 90 J = 1, K + DO 80 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - + $ DCONJG( WORK( I, J ) ) + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C2 +* + DO 100 J = 1, K + CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 100 CONTINUE +* +* W := W * V2 +* + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C1 * V1 +* + CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T' +* + CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V' +* + IF( N.GT.K ) THEN +* +* C1 := C1 - W * V1' +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, + $ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE, + $ C, LDC ) + END IF +* +* W := W * V2' +* + CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', + $ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK, + $ LDWORK ) +* +* C2 := C2 - W +* + DO 120 J = 1, K + DO 110 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) + 110 CONTINUE + 120 CONTINUE + END IF + END IF +* + ELSE IF( LSAME( STOREV, 'R' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 V2 ) (V1: first K columns) +* where V1 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C where C = ( C1 ) +* ( C2 ) +* +* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) +* +* W := C1' +* + DO 130 J = 1, K + CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( N, WORK( 1, J ), 1 ) + 130 CONTINUE +* +* W := W * V1' +* + CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', + $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C2'*V2' +* + CALL ZGEMM( 'Conjugate transpose', + $ 'Conjugate transpose', N, K, M-K, ONE, + $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, + $ WORK, LDWORK ) + END IF +* +* W := W * T' or W * T +* + CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V' * W' +* + IF( M.GT.K ) THEN +* +* C2 := C2 - V2' * W' +* + CALL ZGEMM( 'Conjugate transpose', + $ 'Conjugate transpose', M-K, N, K, -ONE, + $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W' +* + DO 150 J = 1, K + DO 140 I = 1, N + C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) + 140 CONTINUE + 150 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) +* +* W := C1 +* + DO 160 J = 1, K + CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) + 160 CONTINUE +* +* W := W * V1' +* + CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', + $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C2 * V2' +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, + $ K, N-K, ONE, C( 1, K+1 ), LDC, + $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T' +* + CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( N.GT.K ) THEN +* +* C2 := C2 - W * V2 +* + CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 180 J = 1, K + DO 170 I = 1, M + C( I, J ) = C( I, J ) - WORK( I, J ) + 170 CONTINUE + 180 CONTINUE +* + END IF +* + ELSE +* +* Let V = ( V1 V2 ) (V2: last K columns) +* where V2 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C where C = ( C1 ) +* ( C2 ) +* +* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) +* +* W := C2' +* + DO 190 J = 1, K + CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( N, WORK( 1, J ), 1 ) + 190 CONTINUE +* +* W := W * V2' +* + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK, + $ LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C1'*V1' +* + CALL ZGEMM( 'Conjugate transpose', + $ 'Conjugate transpose', N, K, M-K, ONE, C, + $ LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T' or W * T +* + CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V' * W' +* + IF( M.GT.K ) THEN +* +* C1 := C1 - V1' * W' +* + CALL ZGEMM( 'Conjugate transpose', + $ 'Conjugate transpose', M-K, N, K, -ONE, V, + $ LDV, WORK, LDWORK, ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W' +* + DO 210 J = 1, K + DO 200 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - + $ DCONJG( WORK( I, J ) ) + 200 CONTINUE + 210 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) +* +* W := C2 +* + DO 220 J = 1, K + CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 220 CONTINUE +* +* W := W * V2' +* + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK, + $ LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C1 * V1' +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, + $ K, N-K, ONE, C, LDC, V, LDV, ONE, WORK, + $ LDWORK ) + END IF +* +* W := W * T or W * T' +* + CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( N.GT.K ) THEN +* +* C1 := C1 - W * V1 +* + CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 240 J = 1, K + DO 230 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) + 230 CONTINUE + 240 CONTINUE +* + END IF +* + END IF + END IF +* + RETURN +* +* End of ZLARFB +* + END diff --git a/2.3-1/src/fortran/lapack/zlarfg.f b/2.3-1/src/fortran/lapack/zlarfg.f new file mode 100644 index 00000000..d024f928 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlarfg.f @@ -0,0 +1,145 @@ + SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, N + COMPLEX*16 ALPHA, TAU +* .. +* .. Array Arguments .. + COMPLEX*16 X( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER J, KNT + DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2 + COMPLEX*16 ZLADIV + EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN +* .. +* .. External Subroutines .. + EXTERNAL ZDSCAL, ZSCAL +* .. +* .. Executable Statements .. +* + IF( N.LE.0 ) THEN + TAU = ZERO + RETURN + END IF +* + XNORM = DZNRM2( N-1, X, INCX ) + ALPHR = DBLE( ALPHA ) + ALPHI = DIMAG( ALPHA ) +* + IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN +* +* H = I +* + TAU = ZERO + ELSE +* +* general case +* + BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) + SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) + RSAFMN = ONE / SAFMIN +* + IF( ABS( BETA ).LT.SAFMIN ) THEN +* +* XNORM, BETA may be inaccurate; scale X and recompute them +* + KNT = 0 + 10 CONTINUE + KNT = KNT + 1 + CALL ZDSCAL( N-1, RSAFMN, X, INCX ) + BETA = BETA*RSAFMN + ALPHI = ALPHI*RSAFMN + ALPHR = ALPHR*RSAFMN + IF( ABS( BETA ).LT.SAFMIN ) + $ GO TO 10 +* +* New BETA is at most 1, at least SAFMIN +* + XNORM = DZNRM2( N-1, X, INCX ) + ALPHA = DCMPLX( ALPHR, ALPHI ) + BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) + TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) + ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) + CALL ZSCAL( N-1, ALPHA, X, INCX ) +* +* If ALPHA is subnormal, it may lose relative accuracy +* + ALPHA = BETA + DO 20 J = 1, KNT + ALPHA = ALPHA*SAFMIN + 20 CONTINUE + ELSE + TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) + ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) + CALL ZSCAL( N-1, ALPHA, X, INCX ) + ALPHA = BETA + END IF + END IF +* + RETURN +* +* End of ZLARFG +* + END diff --git a/2.3-1/src/fortran/lapack/zlarft.f b/2.3-1/src/fortran/lapack/zlarft.f new file mode 100644 index 00000000..412265e3 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlarft.f @@ -0,0 +1,224 @@ + SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. + COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* 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 .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, J + COMPLEX*16 VII +* .. +* .. External Subroutines .. + EXTERNAL ZGEMV, ZLACGV, ZTRMV +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 20 I = 1, K + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 10 J = 1, I + T( J, I ) = ZERO + 10 CONTINUE + ELSE +* +* general case +* + VII = V( I, I ) + V( I, I ) = ONE + IF( LSAME( STOREV, 'C' ) ) THEN +* +* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) +* + CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1, + $ -TAU( I ), V( I, 1 ), LDV, V( I, I ), 1, + $ ZERO, T( 1, I ), 1 ) + ELSE +* +* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' +* + IF( I.LT.N ) + $ CALL ZLACGV( N-I, V( I, I+1 ), LDV ) + CALL ZGEMV( 'No transpose', I-1, N-I+1, -TAU( I ), + $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, + $ T( 1, I ), 1 ) + IF( I.LT.N ) + $ CALL ZLACGV( N-I, V( I, I+1 ), LDV ) + END IF + V( I, I ) = VII +* +* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) +* + CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, + $ LDT, T( 1, I ), 1 ) + T( I, I ) = TAU( I ) + END IF + 20 CONTINUE + ELSE + DO 40 I = K, 1, -1 + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 30 J = I, K + T( J, I ) = ZERO + 30 CONTINUE + ELSE +* +* general case +* + IF( I.LT.K ) THEN + IF( LSAME( STOREV, 'C' ) ) THEN + VII = V( N-K+I, I ) + V( N-K+I, I ) = ONE +* +* T(i+1:k,i) := +* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) +* + CALL ZGEMV( 'Conjugate transpose', N-K+I, K-I, + $ -TAU( I ), V( 1, I+1 ), LDV, V( 1, I ), + $ 1, ZERO, T( I+1, I ), 1 ) + V( N-K+I, I ) = VII + ELSE + VII = V( I, N-K+I ) + V( I, N-K+I ) = ONE +* +* T(i+1:k,i) := +* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' +* + CALL ZLACGV( N-K+I-1, V( I, 1 ), LDV ) + CALL ZGEMV( 'No transpose', K-I, N-K+I, -TAU( I ), + $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, + $ T( I+1, I ), 1 ) + CALL ZLACGV( N-K+I-1, V( I, 1 ), LDV ) + V( I, N-K+I ) = VII + END IF +* +* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) +* + CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, + $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + END IF + T( I, I ) = TAU( I ) + END IF + 40 CONTINUE + END IF + RETURN +* +* End of ZLARFT +* + END diff --git a/2.3-1/src/fortran/lapack/zlarfx.f b/2.3-1/src/fortran/lapack/zlarfx.f new file mode 100644 index 00000000..327b9d03 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlarfx.f @@ -0,0 +1,641 @@ + SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER LDC, M, N + COMPLEX*16 TAU +* .. +* .. Array Arguments .. + COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER J + COMPLEX*16 SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, + $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZGEMV, ZGERC +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* .. Executable Statements .. +* + IF( TAU.EQ.ZERO ) + $ RETURN + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C, where H has order m. +* + GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, + $ 170, 190 )M +* +* Code for general M +* +* w := C'*v +* + CALL ZGEMV( 'Conjugate transpose', M, N, ONE, C, LDC, V, 1, + $ ZERO, WORK, 1 ) +* +* C := C - tau * v * w' +* + CALL ZGERC( M, N, -TAU, V, 1, WORK, 1, C, LDC ) + GO TO 410 + 10 CONTINUE +* +* Special code for 1 x 1 Householder +* + T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) ) + DO 20 J = 1, N + C( 1, J ) = T1*C( 1, J ) + 20 CONTINUE + GO TO 410 + 30 CONTINUE +* +* Special code for 2 x 2 Householder +* + V1 = DCONJG( V( 1 ) ) + T1 = TAU*DCONJG( V1 ) + V2 = DCONJG( V( 2 ) ) + T2 = TAU*DCONJG( V2 ) + DO 40 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + 40 CONTINUE + GO TO 410 + 50 CONTINUE +* +* Special code for 3 x 3 Householder +* + V1 = DCONJG( V( 1 ) ) + T1 = TAU*DCONJG( V1 ) + V2 = DCONJG( V( 2 ) ) + T2 = TAU*DCONJG( V2 ) + V3 = DCONJG( V( 3 ) ) + T3 = TAU*DCONJG( V3 ) + DO 60 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + 60 CONTINUE + GO TO 410 + 70 CONTINUE +* +* Special code for 4 x 4 Householder +* + V1 = DCONJG( V( 1 ) ) + T1 = TAU*DCONJG( V1 ) + V2 = DCONJG( V( 2 ) ) + T2 = TAU*DCONJG( V2 ) + V3 = DCONJG( V( 3 ) ) + T3 = TAU*DCONJG( V3 ) + V4 = DCONJG( V( 4 ) ) + T4 = TAU*DCONJG( V4 ) + DO 80 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + 80 CONTINUE + GO TO 410 + 90 CONTINUE +* +* Special code for 5 x 5 Householder +* + V1 = DCONJG( V( 1 ) ) + T1 = TAU*DCONJG( V1 ) + V2 = DCONJG( V( 2 ) ) + T2 = TAU*DCONJG( V2 ) + V3 = DCONJG( V( 3 ) ) + T3 = TAU*DCONJG( V3 ) + V4 = DCONJG( V( 4 ) ) + T4 = TAU*DCONJG( V4 ) + V5 = DCONJG( V( 5 ) ) + T5 = TAU*DCONJG( V5 ) + DO 100 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + 100 CONTINUE + GO TO 410 + 110 CONTINUE +* +* Special code for 6 x 6 Householder +* + V1 = DCONJG( V( 1 ) ) + T1 = TAU*DCONJG( V1 ) + V2 = DCONJG( V( 2 ) ) + T2 = TAU*DCONJG( V2 ) + V3 = DCONJG( V( 3 ) ) + T3 = TAU*DCONJG( V3 ) + V4 = DCONJG( V( 4 ) ) + T4 = TAU*DCONJG( V4 ) + V5 = DCONJG( V( 5 ) ) + T5 = TAU*DCONJG( V5 ) + V6 = DCONJG( V( 6 ) ) + T6 = TAU*DCONJG( V6 ) + DO 120 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + C( 6, J ) = C( 6, J ) - SUM*T6 + 120 CONTINUE + GO TO 410 + 130 CONTINUE +* +* Special code for 7 x 7 Householder +* + V1 = DCONJG( V( 1 ) ) + T1 = TAU*DCONJG( V1 ) + V2 = DCONJG( V( 2 ) ) + T2 = TAU*DCONJG( V2 ) + V3 = DCONJG( V( 3 ) ) + T3 = TAU*DCONJG( V3 ) + V4 = DCONJG( V( 4 ) ) + T4 = TAU*DCONJG( V4 ) + V5 = DCONJG( V( 5 ) ) + T5 = TAU*DCONJG( V5 ) + V6 = DCONJG( V( 6 ) ) + T6 = TAU*DCONJG( V6 ) + V7 = DCONJG( V( 7 ) ) + T7 = TAU*DCONJG( V7 ) + DO 140 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + + $ V7*C( 7, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + C( 6, J ) = C( 6, J ) - SUM*T6 + C( 7, J ) = C( 7, J ) - SUM*T7 + 140 CONTINUE + GO TO 410 + 150 CONTINUE +* +* Special code for 8 x 8 Householder +* + V1 = DCONJG( V( 1 ) ) + T1 = TAU*DCONJG( V1 ) + V2 = DCONJG( V( 2 ) ) + T2 = TAU*DCONJG( V2 ) + V3 = DCONJG( V( 3 ) ) + T3 = TAU*DCONJG( V3 ) + V4 = DCONJG( V( 4 ) ) + T4 = TAU*DCONJG( V4 ) + V5 = DCONJG( V( 5 ) ) + T5 = TAU*DCONJG( V5 ) + V6 = DCONJG( V( 6 ) ) + T6 = TAU*DCONJG( V6 ) + V7 = DCONJG( V( 7 ) ) + T7 = TAU*DCONJG( V7 ) + V8 = DCONJG( V( 8 ) ) + T8 = TAU*DCONJG( V8 ) + DO 160 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + + $ V7*C( 7, J ) + V8*C( 8, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + C( 6, J ) = C( 6, J ) - SUM*T6 + C( 7, J ) = C( 7, J ) - SUM*T7 + C( 8, J ) = C( 8, J ) - SUM*T8 + 160 CONTINUE + GO TO 410 + 170 CONTINUE +* +* Special code for 9 x 9 Householder +* + V1 = DCONJG( V( 1 ) ) + T1 = TAU*DCONJG( V1 ) + V2 = DCONJG( V( 2 ) ) + T2 = TAU*DCONJG( V2 ) + V3 = DCONJG( V( 3 ) ) + T3 = TAU*DCONJG( V3 ) + V4 = DCONJG( V( 4 ) ) + T4 = TAU*DCONJG( V4 ) + V5 = DCONJG( V( 5 ) ) + T5 = TAU*DCONJG( V5 ) + V6 = DCONJG( V( 6 ) ) + T6 = TAU*DCONJG( V6 ) + V7 = DCONJG( V( 7 ) ) + T7 = TAU*DCONJG( V7 ) + V8 = DCONJG( V( 8 ) ) + T8 = TAU*DCONJG( V8 ) + V9 = DCONJG( V( 9 ) ) + T9 = TAU*DCONJG( V9 ) + DO 180 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + C( 6, J ) = C( 6, J ) - SUM*T6 + C( 7, J ) = C( 7, J ) - SUM*T7 + C( 8, J ) = C( 8, J ) - SUM*T8 + C( 9, J ) = C( 9, J ) - SUM*T9 + 180 CONTINUE + GO TO 410 + 190 CONTINUE +* +* Special code for 10 x 10 Householder +* + V1 = DCONJG( V( 1 ) ) + T1 = TAU*DCONJG( V1 ) + V2 = DCONJG( V( 2 ) ) + T2 = TAU*DCONJG( V2 ) + V3 = DCONJG( V( 3 ) ) + T3 = TAU*DCONJG( V3 ) + V4 = DCONJG( V( 4 ) ) + T4 = TAU*DCONJG( V4 ) + V5 = DCONJG( V( 5 ) ) + T5 = TAU*DCONJG( V5 ) + V6 = DCONJG( V( 6 ) ) + T6 = TAU*DCONJG( V6 ) + V7 = DCONJG( V( 7 ) ) + T7 = TAU*DCONJG( V7 ) + V8 = DCONJG( V( 8 ) ) + T8 = TAU*DCONJG( V8 ) + V9 = DCONJG( V( 9 ) ) + T9 = TAU*DCONJG( V9 ) + V10 = DCONJG( V( 10 ) ) + T10 = TAU*DCONJG( V10 ) + DO 200 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + + $ V10*C( 10, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + C( 6, J ) = C( 6, J ) - SUM*T6 + C( 7, J ) = C( 7, J ) - SUM*T7 + C( 8, J ) = C( 8, J ) - SUM*T8 + C( 9, J ) = C( 9, J ) - SUM*T9 + C( 10, J ) = C( 10, J ) - SUM*T10 + 200 CONTINUE + GO TO 410 + ELSE +* +* Form C * H, where H has order n. +* + GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, + $ 370, 390 )N +* +* Code for general N +* +* w := C * v +* + CALL ZGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO, + $ WORK, 1 ) +* +* C := C - tau * w * v' +* + CALL ZGERC( M, N, -TAU, WORK, 1, V, 1, C, LDC ) + GO TO 410 + 210 CONTINUE +* +* Special code for 1 x 1 Householder +* + T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) ) + DO 220 J = 1, M + C( J, 1 ) = T1*C( J, 1 ) + 220 CONTINUE + GO TO 410 + 230 CONTINUE +* +* Special code for 2 x 2 Householder +* + V1 = V( 1 ) + T1 = TAU*DCONJG( V1 ) + V2 = V( 2 ) + T2 = TAU*DCONJG( V2 ) + DO 240 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + 240 CONTINUE + GO TO 410 + 250 CONTINUE +* +* Special code for 3 x 3 Householder +* + V1 = V( 1 ) + T1 = TAU*DCONJG( V1 ) + V2 = V( 2 ) + T2 = TAU*DCONJG( V2 ) + V3 = V( 3 ) + T3 = TAU*DCONJG( V3 ) + DO 260 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + 260 CONTINUE + GO TO 410 + 270 CONTINUE +* +* Special code for 4 x 4 Householder +* + V1 = V( 1 ) + T1 = TAU*DCONJG( V1 ) + V2 = V( 2 ) + T2 = TAU*DCONJG( V2 ) + V3 = V( 3 ) + T3 = TAU*DCONJG( V3 ) + V4 = V( 4 ) + T4 = TAU*DCONJG( V4 ) + DO 280 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + 280 CONTINUE + GO TO 410 + 290 CONTINUE +* +* Special code for 5 x 5 Householder +* + V1 = V( 1 ) + T1 = TAU*DCONJG( V1 ) + V2 = V( 2 ) + T2 = TAU*DCONJG( V2 ) + V3 = V( 3 ) + T3 = TAU*DCONJG( V3 ) + V4 = V( 4 ) + T4 = TAU*DCONJG( V4 ) + V5 = V( 5 ) + T5 = TAU*DCONJG( V5 ) + DO 300 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + 300 CONTINUE + GO TO 410 + 310 CONTINUE +* +* Special code for 6 x 6 Householder +* + V1 = V( 1 ) + T1 = TAU*DCONJG( V1 ) + V2 = V( 2 ) + T2 = TAU*DCONJG( V2 ) + V3 = V( 3 ) + T3 = TAU*DCONJG( V3 ) + V4 = V( 4 ) + T4 = TAU*DCONJG( V4 ) + V5 = V( 5 ) + T5 = TAU*DCONJG( V5 ) + V6 = V( 6 ) + T6 = TAU*DCONJG( V6 ) + DO 320 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + C( J, 6 ) = C( J, 6 ) - SUM*T6 + 320 CONTINUE + GO TO 410 + 330 CONTINUE +* +* Special code for 7 x 7 Householder +* + V1 = V( 1 ) + T1 = TAU*DCONJG( V1 ) + V2 = V( 2 ) + T2 = TAU*DCONJG( V2 ) + V3 = V( 3 ) + T3 = TAU*DCONJG( V3 ) + V4 = V( 4 ) + T4 = TAU*DCONJG( V4 ) + V5 = V( 5 ) + T5 = TAU*DCONJG( V5 ) + V6 = V( 6 ) + T6 = TAU*DCONJG( V6 ) + V7 = V( 7 ) + T7 = TAU*DCONJG( V7 ) + DO 340 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + + $ V7*C( J, 7 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + C( J, 6 ) = C( J, 6 ) - SUM*T6 + C( J, 7 ) = C( J, 7 ) - SUM*T7 + 340 CONTINUE + GO TO 410 + 350 CONTINUE +* +* Special code for 8 x 8 Householder +* + V1 = V( 1 ) + T1 = TAU*DCONJG( V1 ) + V2 = V( 2 ) + T2 = TAU*DCONJG( V2 ) + V3 = V( 3 ) + T3 = TAU*DCONJG( V3 ) + V4 = V( 4 ) + T4 = TAU*DCONJG( V4 ) + V5 = V( 5 ) + T5 = TAU*DCONJG( V5 ) + V6 = V( 6 ) + T6 = TAU*DCONJG( V6 ) + V7 = V( 7 ) + T7 = TAU*DCONJG( V7 ) + V8 = V( 8 ) + T8 = TAU*DCONJG( V8 ) + DO 360 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + + $ V7*C( J, 7 ) + V8*C( J, 8 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + C( J, 6 ) = C( J, 6 ) - SUM*T6 + C( J, 7 ) = C( J, 7 ) - SUM*T7 + C( J, 8 ) = C( J, 8 ) - SUM*T8 + 360 CONTINUE + GO TO 410 + 370 CONTINUE +* +* Special code for 9 x 9 Householder +* + V1 = V( 1 ) + T1 = TAU*DCONJG( V1 ) + V2 = V( 2 ) + T2 = TAU*DCONJG( V2 ) + V3 = V( 3 ) + T3 = TAU*DCONJG( V3 ) + V4 = V( 4 ) + T4 = TAU*DCONJG( V4 ) + V5 = V( 5 ) + T5 = TAU*DCONJG( V5 ) + V6 = V( 6 ) + T6 = TAU*DCONJG( V6 ) + V7 = V( 7 ) + T7 = TAU*DCONJG( V7 ) + V8 = V( 8 ) + T8 = TAU*DCONJG( V8 ) + V9 = V( 9 ) + T9 = TAU*DCONJG( V9 ) + DO 380 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + C( J, 6 ) = C( J, 6 ) - SUM*T6 + C( J, 7 ) = C( J, 7 ) - SUM*T7 + C( J, 8 ) = C( J, 8 ) - SUM*T8 + C( J, 9 ) = C( J, 9 ) - SUM*T9 + 380 CONTINUE + GO TO 410 + 390 CONTINUE +* +* Special code for 10 x 10 Householder +* + V1 = V( 1 ) + T1 = TAU*DCONJG( V1 ) + V2 = V( 2 ) + T2 = TAU*DCONJG( V2 ) + V3 = V( 3 ) + T3 = TAU*DCONJG( V3 ) + V4 = V( 4 ) + T4 = TAU*DCONJG( V4 ) + V5 = V( 5 ) + T5 = TAU*DCONJG( V5 ) + V6 = V( 6 ) + T6 = TAU*DCONJG( V6 ) + V7 = V( 7 ) + T7 = TAU*DCONJG( V7 ) + V8 = V( 8 ) + T8 = TAU*DCONJG( V8 ) + V9 = V( 9 ) + T9 = TAU*DCONJG( V9 ) + V10 = V( 10 ) + T10 = TAU*DCONJG( V10 ) + DO 400 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + + $ V10*C( J, 10 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + C( J, 6 ) = C( J, 6 ) - SUM*T6 + C( J, 7 ) = C( J, 7 ) - SUM*T7 + C( J, 8 ) = C( J, 8 ) - SUM*T8 + C( J, 9 ) = C( J, 9 ) - SUM*T9 + C( J, 10 ) = C( J, 10 ) - SUM*T10 + 400 CONTINUE + GO TO 410 + END IF + 410 CONTINUE + RETURN +* +* End of ZLARFX +* + END diff --git a/2.3-1/src/fortran/lapack/zlartg.f b/2.3-1/src/fortran/lapack/zlartg.f new file mode 100644 index 00000000..6d3a850e --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlartg.f @@ -0,0 +1,195 @@ + SUBROUTINE ZLARTG( F, G, CS, SN, R ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION CS + COMPLEX*16 F, G, R, SN +* .. +* +* 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 .. + DOUBLE PRECISION TWO, ONE, ZERO + PARAMETER ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. +* LOGICAL FIRST + INTEGER COUNT, I + DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN, + $ SAFMN2, SAFMX2, SCALE + COMPLEX*16 FF, FS, GS +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG, + $ MAX, SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION ABS1, ABSSQ +* .. +* .. Save statement .. +* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 +* .. +* .. Data statements .. +* DATA FIRST / .TRUE. / +* .. +* .. Statement Function definitions .. + ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) ) + ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2 +* .. +* .. Executable Statements .. +* +* IF( FIRST ) THEN + SAFMIN = DLAMCH( 'S' ) + EPS = DLAMCH( 'E' ) + SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / + $ LOG( DLAMCH( 'B' ) ) / TWO ) + SAFMX2 = ONE / SAFMN2 +* FIRST = .FALSE. +* END IF + SCALE = MAX( ABS1( F ), ABS1( G ) ) + FS = F + GS = G + COUNT = 0 + IF( SCALE.GE.SAFMX2 ) THEN + 10 CONTINUE + COUNT = COUNT + 1 + FS = FS*SAFMN2 + GS = GS*SAFMN2 + SCALE = SCALE*SAFMN2 + IF( SCALE.GE.SAFMX2 ) + $ GO TO 10 + ELSE IF( SCALE.LE.SAFMN2 ) THEN + IF( G.EQ.CZERO ) THEN + CS = ONE + SN = CZERO + R = F + RETURN + END IF + 20 CONTINUE + COUNT = COUNT - 1 + FS = FS*SAFMX2 + GS = GS*SAFMX2 + SCALE = SCALE*SAFMX2 + IF( SCALE.LE.SAFMN2 ) + $ GO TO 20 + END IF + F2 = ABSSQ( FS ) + G2 = ABSSQ( GS ) + IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN +* +* This is a rare case: F is very small. +* + IF( F.EQ.CZERO ) THEN + CS = ZERO + R = DLAPY2( DBLE( G ), DIMAG( G ) ) +* Do complex/real division explicitly with two real divisions + D = DLAPY2( DBLE( GS ), DIMAG( GS ) ) + SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D ) + RETURN + END IF + F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) ) +* 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 + IF( ABS1( F ).GT.ONE ) THEN + D = DLAPY2( DBLE( F ), DIMAG( F ) ) + FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D ) + ELSE + DR = SAFMX2*DBLE( F ) + DI = SAFMX2*DIMAG( F ) + D = DLAPY2( DR, DI ) + FF = DCMPLX( DR / D, DI / D ) + END IF + SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S ) + R = CS*F + SN*G + 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( ONE+G2 / F2 ) +* Do the F2S(real)*FS(complex) multiply with two real multiplies + R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) ) + CS = ONE / F2S + D = F2 + G2 +* Do complex/real division explicitly with two real divisions + SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D ) + SN = SN*DCONJG( GS ) + IF( COUNT.NE.0 ) THEN + IF( COUNT.GT.0 ) THEN + DO 30 I = 1, COUNT + R = R*SAFMX2 + 30 CONTINUE + ELSE + DO 40 I = 1, -COUNT + R = R*SAFMN2 + 40 CONTINUE + END IF + END IF + END IF + RETURN +* +* End of ZLARTG +* + END diff --git a/2.3-1/src/fortran/lapack/zlarz.f b/2.3-1/src/fortran/lapack/zlarz.f new file mode 100644 index 00000000..18124672 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlarz.f @@ -0,0 +1,157 @@ + SUBROUTINE ZLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, L, LDC, M, N + COMPLEX*16 TAU +* .. +* .. Array Arguments .. + COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZCOPY, ZGEMV, ZGERC, ZGERU, ZLACGV +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C +* + IF( TAU.NE.ZERO ) THEN +* +* w( 1:n ) = conjg( C( 1, 1:n ) ) +* + CALL ZCOPY( N, C, LDC, WORK, 1 ) + CALL ZLACGV( N, WORK, 1 ) +* +* w( 1:n ) = conjg( w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) ) +* + CALL ZGEMV( 'Conjugate transpose', L, N, ONE, C( M-L+1, 1 ), + $ LDC, V, INCV, ONE, WORK, 1 ) + CALL ZLACGV( N, WORK, 1 ) +* +* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) +* + CALL ZAXPY( N, -TAU, WORK, 1, C, LDC ) +* +* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... +* tau * v( 1:l ) * conjg( w( 1:n )' ) +* + CALL ZGERU( L, N, -TAU, V, INCV, WORK, 1, C( M-L+1, 1 ), + $ LDC ) + END IF +* + ELSE +* +* Form C * H +* + IF( TAU.NE.ZERO ) THEN +* +* w( 1:m ) = C( 1:m, 1 ) +* + CALL ZCOPY( M, C, 1, WORK, 1 ) +* +* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) +* + CALL ZGEMV( 'No transpose', M, L, ONE, C( 1, N-L+1 ), LDC, + $ V, INCV, ONE, WORK, 1 ) +* +* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) +* + CALL ZAXPY( M, -TAU, WORK, 1, C, 1 ) +* +* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... +* tau * w( 1:m ) * v( 1:l )' +* + CALL ZGERC( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ), + $ LDC ) +* + END IF +* + END IF +* + RETURN +* +* End of ZLARZ +* + END diff --git a/2.3-1/src/fortran/lapack/zlarzb.f b/2.3-1/src/fortran/lapack/zlarzb.f new file mode 100644 index 00000000..05d2a0e3 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlarzb.f @@ -0,0 +1,234 @@ + SUBROUTINE ZLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, + $ LDV, T, LDT, C, LDC, WORK, LDWORK ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), + $ WORK( LDWORK, * ) +* .. +* +* 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 .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + CHARACTER TRANST + INTEGER I, INFO, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZCOPY, ZGEMM, ZLACGV, ZTRMM +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* +* Check for currently supported options +* + INFO = 0 + IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN + INFO = -3 + ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLARZB', -INFO ) + RETURN + END IF +* + IF( LSAME( TRANS, 'N' ) ) THEN + TRANST = 'C' + ELSE + TRANST = 'N' + END IF +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C +* +* W( 1:n, 1:k ) = conjg( C( 1:k, 1:n )' ) +* + DO 10 J = 1, K + CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 10 CONTINUE +* +* 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.GT.0 ) + $ CALL ZGEMM( 'Transpose', 'Conjugate transpose', N, K, L, + $ ONE, C( M-L+1, 1 ), LDC, V, LDV, ONE, WORK, + $ LDWORK ) +* +* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T +* + CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, ONE, T, + $ LDT, WORK, LDWORK ) +* +* C( 1:k, 1:n ) = C( 1:k, 1:n ) - conjg( W( 1:n, 1:k )' ) +* + DO 30 J = 1, N + DO 20 I = 1, K + C( I, J ) = C( I, J ) - WORK( J, I ) + 20 CONTINUE + 30 CONTINUE +* +* 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.GT.0 ) + $ CALL ZGEMM( 'Transpose', 'Transpose', L, N, K, -ONE, V, LDV, + $ WORK, LDWORK, ONE, C( M-L+1, 1 ), LDC ) +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' +* +* W( 1:m, 1:k ) = C( 1:m, 1:k ) +* + DO 40 J = 1, K + CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) + 40 CONTINUE +* +* 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.GT.0 ) + $ CALL ZGEMM( 'No transpose', 'Transpose', M, K, L, ONE, + $ C( 1, N-L+1 ), LDC, V, LDV, ONE, WORK, LDWORK ) +* +* W( 1:m, 1:k ) = W( 1:m, 1:k ) * conjg( T ) or +* W( 1:m, 1:k ) * conjg( T' ) +* + DO 50 J = 1, K + CALL ZLACGV( K-J+1, T( J, J ), 1 ) + 50 CONTINUE + CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, ONE, T, + $ LDT, WORK, LDWORK ) + DO 60 J = 1, K + CALL ZLACGV( K-J+1, T( J, J ), 1 ) + 60 CONTINUE +* +* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k ) +* + DO 80 J = 1, K + DO 70 I = 1, M + C( I, J ) = C( I, J ) - WORK( I, J ) + 70 CONTINUE + 80 CONTINUE +* +* 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 ) ) +* + DO 90 J = 1, L + CALL ZLACGV( K, V( 1, J ), 1 ) + 90 CONTINUE + IF( L.GT.0 ) + $ CALL ZGEMM( 'No transpose', 'No transpose', M, L, K, -ONE, + $ WORK, LDWORK, V, LDV, ONE, C( 1, N-L+1 ), LDC ) + DO 100 J = 1, L + CALL ZLACGV( K, V( 1, J ), 1 ) + 100 CONTINUE +* + END IF +* + RETURN +* +* End of ZLARZB +* + END diff --git a/2.3-1/src/fortran/lapack/zlarzt.f b/2.3-1/src/fortran/lapack/zlarzt.f new file mode 100644 index 00000000..9242ed36 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlarzt.f @@ -0,0 +1,186 @@ + SUBROUTINE ZLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. + COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGEMV, ZLACGV, ZTRMV +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Check for currently supported options +* + INFO = 0 + IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLARZT', -INFO ) + RETURN + END IF +* + DO 20 I = K, 1, -1 + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 10 J = I, K + T( J, I ) = ZERO + 10 CONTINUE + ELSE +* +* general case +* + IF( I.LT.K ) THEN +* +* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)' +* + CALL ZLACGV( N, V( I, 1 ), LDV ) + CALL ZGEMV( 'No transpose', K-I, N, -TAU( I ), + $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, + $ T( I+1, I ), 1 ) + CALL ZLACGV( N, V( I, 1 ), LDV ) +* +* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i) +* + CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, + $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + END IF + T( I, I ) = TAU( I ) + END IF + 20 CONTINUE + RETURN +* +* End of ZLARZT +* + END diff --git a/2.3-1/src/fortran/lapack/zlascl.f b/2.3-1/src/fortran/lapack/zlascl.f new file mode 100644 index 00000000..36bb2445 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlascl.f @@ -0,0 +1,267 @@ + SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, KL, KU, LDA, M, N + DOUBLE PRECISION CFROM, CTO +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER I, ITYPE, J, K1, K2, K3, K4 + DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 +* + IF( LSAME( TYPE, 'G' ) ) THEN + ITYPE = 0 + ELSE IF( LSAME( TYPE, 'L' ) ) THEN + ITYPE = 1 + ELSE IF( LSAME( TYPE, 'U' ) ) THEN + ITYPE = 2 + ELSE IF( LSAME( TYPE, 'H' ) ) THEN + ITYPE = 3 + ELSE IF( LSAME( TYPE, 'B' ) ) THEN + ITYPE = 4 + ELSE IF( LSAME( TYPE, 'Q' ) ) THEN + ITYPE = 5 + ELSE IF( LSAME( TYPE, 'Z' ) ) THEN + ITYPE = 6 + ELSE + ITYPE = -1 + END IF +* + IF( ITYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( CFROM.EQ.ZERO ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. + $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN + INFO = -7 + ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( ITYPE.GE.4 ) THEN + IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN + INFO = -2 + ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. + $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) + $ THEN + INFO = -3 + ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. + $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. + $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN + INFO = -9 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLASCL', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +* +* Get machine parameters +* + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM +* + CFROMC = CFROM + CTOC = CTO +* + 10 CONTINUE + CFROM1 = CFROMC*SMLNUM + CTO1 = CTOC / BIGNUM + IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN + MUL = SMLNUM + DONE = .FALSE. + CFROMC = CFROM1 + ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN + MUL = BIGNUM + DONE = .FALSE. + CTOC = CTO1 + ELSE + MUL = CTOC / CFROMC + DONE = .TRUE. + END IF +* + IF( ITYPE.EQ.0 ) THEN +* +* Full matrix +* + DO 30 J = 1, N + DO 20 I = 1, M + A( I, J ) = A( I, J )*MUL + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( ITYPE.EQ.1 ) THEN +* +* Lower triangular matrix +* + DO 50 J = 1, N + DO 40 I = J, M + A( I, J ) = A( I, J )*MUL + 40 CONTINUE + 50 CONTINUE +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Upper triangular matrix +* + DO 70 J = 1, N + DO 60 I = 1, MIN( J, M ) + A( I, J ) = A( I, J )*MUL + 60 CONTINUE + 70 CONTINUE +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* Upper Hessenberg matrix +* + DO 90 J = 1, N + DO 80 I = 1, MIN( J+1, M ) + A( I, J ) = A( I, J )*MUL + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Lower half of a symmetric band matrix +* + K3 = KL + 1 + K4 = N + 1 + DO 110 J = 1, N + DO 100 I = 1, MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 100 CONTINUE + 110 CONTINUE +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Upper half of a symmetric band matrix +* + K1 = KU + 2 + K3 = KU + 1 + DO 130 J = 1, N + DO 120 I = MAX( K1-J, 1 ), K3 + A( I, J ) = A( I, J )*MUL + 120 CONTINUE + 130 CONTINUE +* + ELSE IF( ITYPE.EQ.6 ) THEN +* +* Band matrix +* + K1 = KL + KU + 2 + K2 = KL + 1 + K3 = 2*KL + KU + 1 + K4 = KL + KU + 1 + M + DO 150 J = 1, N + DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 140 CONTINUE + 150 CONTINUE +* + END IF +* + IF( .NOT.DONE ) + $ GO TO 10 +* + RETURN +* +* End of ZLASCL +* + END diff --git a/2.3-1/src/fortran/lapack/zlaset.f b/2.3-1/src/fortran/lapack/zlaset.f new file mode 100644 index 00000000..88fc21b2 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlaset.f @@ -0,0 +1,114 @@ + SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, M, N + COMPLEX*16 ALPHA, BETA +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* 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 .. + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Set the diagonal to BETA and the strictly upper triangular +* part of the array to ALPHA. +* + DO 20 J = 2, N + DO 10 I = 1, MIN( J-1, M ) + A( I, J ) = ALPHA + 10 CONTINUE + 20 CONTINUE + DO 30 I = 1, MIN( N, M ) + A( I, I ) = BETA + 30 CONTINUE +* + ELSE IF( LSAME( UPLO, 'L' ) ) THEN +* +* Set the diagonal to BETA and the strictly lower triangular +* part of the array to ALPHA. +* + DO 50 J = 1, MIN( M, N ) + DO 40 I = J + 1, M + A( I, J ) = ALPHA + 40 CONTINUE + 50 CONTINUE + DO 60 I = 1, MIN( N, M ) + A( I, I ) = BETA + 60 CONTINUE +* + ELSE +* +* Set the array to BETA on the diagonal and ALPHA on the +* offdiagonal. +* + DO 80 J = 1, N + DO 70 I = 1, M + A( I, J ) = ALPHA + 70 CONTINUE + 80 CONTINUE + DO 90 I = 1, MIN( M, N ) + A( I, I ) = BETA + 90 CONTINUE + END IF +* + RETURN +* +* End of ZLASET +* + END diff --git a/2.3-1/src/fortran/lapack/zlasr.f b/2.3-1/src/fortran/lapack/zlasr.f new file mode 100644 index 00000000..507a20c4 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlasr.f @@ -0,0 +1,363 @@ + SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, PIVOT, SIDE + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( * ), S( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + DOUBLE PRECISION CTEMP, STEMP + COMPLEX*16 TEMP +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN + INFO = 1 + ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, + $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN + INFO = 2 + ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) + $ THEN + INFO = 3 + ELSE IF( M.LT.0 ) THEN + INFO = 4 + ELSE IF( N.LT.0 ) THEN + INFO = 5 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = 9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLASR ', INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) + $ RETURN + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form P * A +* + IF( LSAME( PIVOT, 'V' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 20 J = 1, M - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 10 I = 1, N + TEMP = A( J+1, I ) + A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) + A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 40 J = M - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 30 I = 1, N + TEMP = A( J+1, I ) + A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) + A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) + 30 CONTINUE + END IF + 40 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'T' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 60 J = 2, M + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 50 I = 1, N + TEMP = A( J, I ) + A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) + A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 80 J = M, 2, -1 + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 70 I = 1, N + TEMP = A( J, I ) + A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) + A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) + 70 CONTINUE + END IF + 80 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'B' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 100 J = 1, M - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 90 I = 1, N + TEMP = A( J, I ) + A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP + A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP + 90 CONTINUE + END IF + 100 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 120 J = M - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 110 I = 1, N + TEMP = A( J, I ) + A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP + A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP + 110 CONTINUE + END IF + 120 CONTINUE + END IF + END IF + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form A * P' +* + IF( LSAME( PIVOT, 'V' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 140 J = 1, N - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 130 I = 1, M + TEMP = A( I, J+1 ) + A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) + A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) + 130 CONTINUE + END IF + 140 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 160 J = N - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 150 I = 1, M + TEMP = A( I, J+1 ) + A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) + A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) + 150 CONTINUE + END IF + 160 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'T' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 180 J = 2, N + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 170 I = 1, M + TEMP = A( I, J ) + A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) + A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) + 170 CONTINUE + END IF + 180 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 200 J = N, 2, -1 + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 190 I = 1, M + TEMP = A( I, J ) + A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) + A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) + 190 CONTINUE + END IF + 200 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'B' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 220 J = 1, N - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 210 I = 1, M + TEMP = A( I, J ) + A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP + A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP + 210 CONTINUE + END IF + 220 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 240 J = N - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 230 I = 1, M + TEMP = A( I, J ) + A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP + A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP + 230 CONTINUE + END IF + 240 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZLASR +* + END diff --git a/2.3-1/src/fortran/lapack/zlassq.f b/2.3-1/src/fortran/lapack/zlassq.f new file mode 100644 index 00000000..a209984b --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlassq.f @@ -0,0 +1,101 @@ + SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION SCALE, SUMSQ +* .. +* .. Array Arguments .. + COMPLEX*16 X( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER IX + DOUBLE PRECISION TEMP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG +* .. +* .. Executable Statements .. +* + IF( N.GT.0 ) THEN + DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX + IF( DBLE( X( IX ) ).NE.ZERO ) THEN + TEMP1 = ABS( DBLE( X( IX ) ) ) + IF( SCALE.LT.TEMP1 ) THEN + SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 + SCALE = TEMP1 + ELSE + SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 + END IF + END IF + IF( DIMAG( X( IX ) ).NE.ZERO ) THEN + TEMP1 = ABS( DIMAG( X( IX ) ) ) + IF( SCALE.LT.TEMP1 ) THEN + SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 + SCALE = TEMP1 + ELSE + SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 + END IF + END IF + 10 CONTINUE + END IF +* + RETURN +* +* End of ZLASSQ +* + END diff --git a/2.3-1/src/fortran/lapack/zlaswp.f b/2.3-1/src/fortran/lapack/zlaswp.f new file mode 100644 index 00000000..8b07e48b --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlaswp.f @@ -0,0 +1,119 @@ + SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, K1, K2, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* 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 .. + INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 + COMPLEX*16 TEMP +* .. +* .. Executable Statements .. +* +* Interchange row I with row IPIV(I) for each of rows K1 through K2. +* + IF( INCX.GT.0 ) THEN + IX0 = K1 + I1 = K1 + I2 = K2 + INC = 1 + ELSE IF( INCX.LT.0 ) THEN + IX0 = 1 + ( 1-K2 )*INCX + I1 = K2 + I2 = K1 + INC = -1 + ELSE + RETURN + END IF +* + N32 = ( N / 32 )*32 + IF( N32.NE.0 ) THEN + DO 30 J = 1, N32, 32 + IX = IX0 + DO 20 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 10 K = J, J + 31 + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 10 CONTINUE + END IF + IX = IX + INCX + 20 CONTINUE + 30 CONTINUE + END IF + IF( N32.NE.N ) THEN + N32 = N32 + 1 + IX = IX0 + DO 50 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 40 K = N32, N + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 40 CONTINUE + END IF + IX = IX + INCX + 50 CONTINUE + END IF +* + RETURN +* +* End of ZLASWP +* + END diff --git a/2.3-1/src/fortran/lapack/zlatdf.f b/2.3-1/src/fortran/lapack/zlatdf.f new file mode 100644 index 00000000..d637b8f1 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlatdf.f @@ -0,0 +1,241 @@ + SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, + $ JPIV ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IJOB, LDZ, N + DOUBLE PRECISION RDSCAL, RDSUM +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), JPIV( * ) + COMPLEX*16 RHS( * ), Z( LDZ, * ) +* .. +* +* 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 .. + INTEGER MAXDIM + PARAMETER ( MAXDIM = 2 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J, K + DOUBLE PRECISION RTEMP, SCALE, SMINU, SPLUS + COMPLEX*16 BM, BP, PMONE, TEMP +* .. +* .. Local Arrays .. + DOUBLE PRECISION RWORK( MAXDIM ) + COMPLEX*16 WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM ) +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZCOPY, ZGECON, ZGESC2, ZLASSQ, ZLASWP, + $ ZSCAL +* .. +* .. External Functions .. + DOUBLE PRECISION DZASUM + COMPLEX*16 ZDOTC + EXTERNAL DZASUM, ZDOTC +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, SQRT +* .. +* .. Executable Statements .. +* + IF( IJOB.NE.2 ) THEN +* +* Apply permutations IPIV to RHS +* + CALL ZLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 ) +* +* Solve for L-part choosing RHS either to +1 or -1. +* + PMONE = -CONE + DO 10 J = 1, N - 1 + BP = RHS( J ) + CONE + BM = RHS( J ) - CONE + SPLUS = ONE +* +* Lockahead for L- part RHS(1:N-1) = +-1 +* SPLUS and SMIN computed more efficiently than in BSOLVE[1]. +* + SPLUS = SPLUS + DBLE( ZDOTC( N-J, Z( J+1, J ), 1, Z( J+1, + $ J ), 1 ) ) + SMINU = DBLE( ZDOTC( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 ) ) + SPLUS = SPLUS*DBLE( RHS( J ) ) + IF( SPLUS.GT.SMINU ) THEN + RHS( J ) = BP + ELSE IF( SMINU.GT.SPLUS ) THEN + 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 ) = RHS( J ) + PMONE + PMONE = CONE + END IF +* +* Compute the remaining r.h.s. +* + TEMP = -RHS( J ) + CALL ZAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 ) + 10 CONTINUE +* +* 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). +* + CALL ZCOPY( N-1, RHS, 1, WORK, 1 ) + WORK( N ) = RHS( N ) + CONE + RHS( N ) = RHS( N ) - CONE + SPLUS = ZERO + SMINU = ZERO + DO 30 I = N, 1, -1 + TEMP = CONE / Z( I, I ) + WORK( I ) = WORK( I )*TEMP + RHS( I ) = RHS( I )*TEMP + DO 20 K = I + 1, N + WORK( I ) = WORK( I ) - WORK( K )*( Z( I, K )*TEMP ) + RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP ) + 20 CONTINUE + SPLUS = SPLUS + ABS( WORK( I ) ) + SMINU = SMINU + ABS( RHS( I ) ) + 30 CONTINUE + IF( SPLUS.GT.SMINU ) + $ CALL ZCOPY( N, WORK, 1, RHS, 1 ) +* +* Apply the permutations JPIV to the computed solution (RHS) +* + CALL ZLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 ) +* +* Compute the sum of squares +* + CALL ZLASSQ( N, RHS, 1, RDSCAL, RDSUM ) + RETURN + END IF +* +* ENTRY IJOB = 2 +* +* Compute approximate nullvector XM of Z +* + CALL ZGECON( 'I', N, Z, LDZ, ONE, RTEMP, WORK, RWORK, INFO ) + CALL ZCOPY( N, WORK( N+1 ), 1, XM, 1 ) +* +* Compute RHS +* + CALL ZLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 ) + TEMP = CONE / SQRT( ZDOTC( N, XM, 1, XM, 1 ) ) + CALL ZSCAL( N, TEMP, XM, 1 ) + CALL ZCOPY( N, XM, 1, XP, 1 ) + CALL ZAXPY( N, CONE, RHS, 1, XP, 1 ) + CALL ZAXPY( N, -CONE, XM, 1, RHS, 1 ) + CALL ZGESC2( N, Z, LDZ, RHS, IPIV, JPIV, SCALE ) + CALL ZGESC2( N, Z, LDZ, XP, IPIV, JPIV, SCALE ) + IF( DZASUM( N, XP, 1 ).GT.DZASUM( N, RHS, 1 ) ) + $ CALL ZCOPY( N, XP, 1, RHS, 1 ) +* +* Compute the sum of squares +* + CALL ZLASSQ( N, RHS, 1, RDSCAL, RDSUM ) + RETURN +* +* End of ZLATDF +* + END diff --git a/2.3-1/src/fortran/lapack/zlatrd.f b/2.3-1/src/fortran/lapack/zlatrd.f new file mode 100644 index 00000000..5fef7b5c --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlatrd.f @@ -0,0 +1,279 @@ + SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDW, N, NB +* .. +* .. Array Arguments .. + DOUBLE PRECISION E( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO, ONE, HALF + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ), + $ HALF = ( 0.5D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, IW + COMPLEX*16 ALPHA +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZGEMV, ZHEMV, ZLACGV, ZLARFG, ZSCAL +* .. +* .. External Functions .. + LOGICAL LSAME + COMPLEX*16 ZDOTC + EXTERNAL LSAME, ZDOTC +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Reduce last NB columns of upper triangle +* + DO 10 I = N, N - NB + 1, -1 + IW = I - N + NB + IF( I.LT.N ) THEN +* +* Update A(1:i,i) +* + A( I, I ) = DBLE( A( I, I ) ) + CALL ZLACGV( N-I, W( I, IW+1 ), LDW ) + CALL ZGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), + $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) + CALL ZLACGV( N-I, W( I, IW+1 ), LDW ) + CALL ZLACGV( N-I, A( I, I+1 ), LDA ) + CALL ZGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), + $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) + CALL ZLACGV( N-I, A( I, I+1 ), LDA ) + A( I, I ) = DBLE( A( I, I ) ) + END IF + IF( I.GT.1 ) THEN +* +* Generate elementary reflector H(i) to annihilate +* A(1:i-2,i) +* + ALPHA = A( I-1, I ) + CALL ZLARFG( I-1, ALPHA, A( 1, I ), 1, TAU( I-1 ) ) + E( I-1 ) = ALPHA + A( I-1, I ) = ONE +* +* Compute W(1:i-1,i) +* + CALL ZHEMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, + $ ZERO, W( 1, IW ), 1 ) + IF( I.LT.N ) THEN + CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE, + $ W( 1, IW+1 ), LDW, A( 1, I ), 1, ZERO, + $ W( I+1, IW ), 1 ) + CALL ZGEMV( 'No transpose', I-1, N-I, -ONE, + $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, + $ W( 1, IW ), 1 ) + CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE, + $ A( 1, I+1 ), LDA, A( 1, I ), 1, ZERO, + $ W( I+1, IW ), 1 ) + CALL ZGEMV( 'No transpose', I-1, N-I, -ONE, + $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, + $ W( 1, IW ), 1 ) + END IF + CALL ZSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) + ALPHA = -HALF*TAU( I-1 )*ZDOTC( I-1, W( 1, IW ), 1, + $ A( 1, I ), 1 ) + CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) + END IF +* + 10 CONTINUE + ELSE +* +* Reduce first NB columns of lower triangle +* + DO 20 I = 1, NB +* +* Update A(i:n,i) +* + A( I, I ) = DBLE( A( I, I ) ) + CALL ZLACGV( I-1, W( I, 1 ), LDW ) + CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), + $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) + CALL ZLACGV( I-1, W( I, 1 ), LDW ) + CALL ZLACGV( I-1, A( I, 1 ), LDA ) + CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), + $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) + CALL ZLACGV( I-1, A( I, 1 ), LDA ) + A( I, I ) = DBLE( A( I, I ) ) + IF( I.LT.N ) THEN +* +* Generate elementary reflector H(i) to annihilate +* A(i+2:n,i) +* + ALPHA = A( I+1, I ) + CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, + $ TAU( I ) ) + E( I ) = ALPHA + A( I+1, I ) = ONE +* +* Compute W(i+1:n,i) +* + CALL ZHEMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, + $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) + CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, + $ W( I+1, 1 ), LDW, A( I+1, I ), 1, ZERO, + $ W( 1, I ), 1 ) + CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), + $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) + CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, + $ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO, + $ W( 1, I ), 1 ) + CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), + $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) + CALL ZSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) + ALPHA = -HALF*TAU( I )*ZDOTC( N-I, W( I+1, I ), 1, + $ A( I+1, I ), 1 ) + CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) + END IF +* + 20 CONTINUE + END IF +* + RETURN +* +* End of ZLATRD +* + END diff --git a/2.3-1/src/fortran/lapack/zlatrs.f b/2.3-1/src/fortran/lapack/zlatrs.f new file mode 100644 index 00000000..7466096c --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlatrs.f @@ -0,0 +1,879 @@ + SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, + $ CNORM, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIAG, NORMIN, TRANS, UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. + DOUBLE PRECISION CNORM( * ) + COMPLEX*16 A( LDA, * ), X( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, HALF, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, + $ TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN, NOUNIT, UPPER + INTEGER I, IMAX, J, JFIRST, JINC, JLAST + DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL, + $ XBND, XJ, XMAX + COMPLEX*16 CSUMJ, TJJS, USCAL, ZDUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, IZAMAX + DOUBLE PRECISION DLAMCH, DZASUM + COMPLEX*16 ZDOTC, ZDOTU, ZLADIV + EXTERNAL LSAME, IDAMAX, IZAMAX, DLAMCH, DZASUM, ZDOTC, + $ ZDOTU, ZLADIV +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, XERBLA, ZAXPY, ZDSCAL, ZTRSV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1, CABS2 +* .. +* .. Statement Function definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) + CABS2( ZDUM ) = ABS( DBLE( ZDUM ) / 2.D0 ) + + $ ABS( DIMAG( ZDUM ) / 2.D0 ) +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + NOTRAN = LSAME( TRANS, 'N' ) + NOUNIT = LSAME( DIAG, 'N' ) +* +* Test the input parameters. +* + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN + INFO = -3 + ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. + $ LSAME( NORMIN, 'N' ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLATRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine machine dependent parameters to control overflow. +* + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + SCALE = ONE +* + IF( LSAME( NORMIN, 'N' ) ) THEN +* +* Compute the 1-norm of each column, not including the diagonal. +* + IF( UPPER ) THEN +* +* A is upper triangular. +* + DO 10 J = 1, N + CNORM( J ) = DZASUM( J-1, A( 1, J ), 1 ) + 10 CONTINUE + ELSE +* +* A is lower triangular. +* + DO 20 J = 1, N - 1 + CNORM( J ) = DZASUM( N-J, A( J+1, J ), 1 ) + 20 CONTINUE + CNORM( N ) = ZERO + END IF + END IF +* +* Scale the column norms by TSCAL if the maximum element in CNORM is +* greater than BIGNUM/2. +* + IMAX = IDAMAX( N, CNORM, 1 ) + TMAX = CNORM( IMAX ) + IF( TMAX.LE.BIGNUM*HALF ) THEN + TSCAL = ONE + ELSE + TSCAL = HALF / ( SMLNUM*TMAX ) + CALL DSCAL( N, TSCAL, CNORM, 1 ) + END IF +* +* Compute a bound on the computed solution vector to see if the +* Level 2 BLAS routine ZTRSV can be used. +* + XMAX = ZERO + DO 30 J = 1, N + XMAX = MAX( XMAX, CABS2( X( J ) ) ) + 30 CONTINUE + XBND = XMAX +* + IF( NOTRAN ) THEN +* +* Compute the growth in A * x = b. +* + IF( UPPER ) THEN + JFIRST = N + JLAST = 1 + JINC = -1 + ELSE + JFIRST = 1 + JLAST = N + JINC = 1 + END IF +* + IF( TSCAL.NE.ONE ) THEN + GROW = ZERO + GO TO 60 + END IF +* + IF( NOUNIT ) THEN +* +* 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 = HALF / MAX( XBND, SMLNUM ) + XBND = GROW + DO 40 J = JFIRST, JLAST, JINC +* +* Exit the loop if the growth factor is too small. +* + IF( GROW.LE.SMLNUM ) + $ GO TO 60 +* + TJJS = A( J, J ) + TJJ = CABS1( TJJS ) +* + IF( TJJ.GE.SMLNUM ) THEN +* +* M(j) = G(j-1) / abs(A(j,j)) +* + XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) + ELSE +* +* M(j) could overflow, set XBND to 0. +* + XBND = ZERO + END IF +* + IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN +* +* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) +* + GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) + ELSE +* +* G(j) could overflow, set GROW to 0. +* + GROW = ZERO + END IF + 40 CONTINUE + GROW = XBND + ELSE +* +* A is unit triangular. +* +* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. +* + GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) + DO 50 J = JFIRST, JLAST, JINC +* +* Exit the loop if the growth factor is too small. +* + IF( GROW.LE.SMLNUM ) + $ GO TO 60 +* +* G(j) = G(j-1)*( 1 + CNORM(j) ) +* + GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) + 50 CONTINUE + END IF + 60 CONTINUE +* + ELSE +* +* Compute the growth in A**T * x = b or A**H * x = b. +* + IF( UPPER ) THEN + JFIRST = 1 + JLAST = N + JINC = 1 + ELSE + JFIRST = N + JLAST = 1 + JINC = -1 + END IF +* + IF( TSCAL.NE.ONE ) THEN + GROW = ZERO + GO TO 90 + END IF +* + IF( NOUNIT ) THEN +* +* 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 = HALF / MAX( XBND, SMLNUM ) + XBND = GROW + DO 70 J = JFIRST, JLAST, JINC +* +* Exit the loop if the growth factor is too small. +* + IF( GROW.LE.SMLNUM ) + $ GO TO 90 +* +* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) +* + XJ = ONE + CNORM( J ) + GROW = MIN( GROW, XBND / XJ ) +* + TJJS = A( J, J ) + TJJ = CABS1( TJJS ) +* + IF( TJJ.GE.SMLNUM ) THEN +* +* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) +* + IF( XJ.GT.TJJ ) + $ XBND = XBND*( TJJ / XJ ) + ELSE +* +* M(j) could overflow, set XBND to 0. +* + XBND = ZERO + END IF + 70 CONTINUE + GROW = MIN( GROW, XBND ) + ELSE +* +* A is unit triangular. +* +* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. +* + GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) + DO 80 J = JFIRST, JLAST, JINC +* +* Exit the loop if the growth factor is too small. +* + IF( GROW.LE.SMLNUM ) + $ GO TO 90 +* +* G(j) = ( 1 + CNORM(j) )*G(j-1) +* + XJ = ONE + CNORM( J ) + GROW = GROW / XJ + 80 CONTINUE + END IF + 90 CONTINUE + END IF +* + IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN +* +* Use the Level 2 BLAS solve if the reciprocal of the bound on +* elements of X is not too small. +* + CALL ZTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) + ELSE +* +* Use a Level 1 BLAS solve, scaling intermediate results. +* + IF( XMAX.GT.BIGNUM*HALF ) THEN +* +* Scale X so that its components are less than or equal to +* BIGNUM in absolute value. +* + SCALE = ( BIGNUM*HALF ) / XMAX + CALL ZDSCAL( N, SCALE, X, 1 ) + XMAX = BIGNUM + ELSE + XMAX = XMAX*TWO + END IF +* + IF( NOTRAN ) THEN +* +* Solve A * x = b +* + DO 120 J = JFIRST, JLAST, JINC +* +* Compute x(j) = b(j) / A(j,j), scaling x if necessary. +* + XJ = CABS1( X( J ) ) + IF( NOUNIT ) THEN + TJJS = A( J, J )*TSCAL + ELSE + TJJS = TSCAL + IF( TSCAL.EQ.ONE ) + $ GO TO 110 + END IF + TJJ = CABS1( TJJS ) + IF( TJJ.GT.SMLNUM ) THEN +* +* abs(A(j,j)) > SMLNUM: +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale x by 1/b(j). +* + REC = ONE / XJ + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + X( J ) = ZLADIV( X( J ), TJJS ) + XJ = CABS1( X( J ) ) + ELSE IF( TJJ.GT.ZERO ) THEN +* +* 0 < abs(A(j,j)) <= SMLNUM: +* + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* 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 ).GT.ONE ) THEN +* +* Scale by 1/CNORM(j) to avoid overflow when +* multiplying x(j) times column j. +* + REC = REC / CNORM( J ) + END IF + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + X( J ) = ZLADIV( X( J ), TJJS ) + XJ = CABS1( X( J ) ) + ELSE +* +* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and +* scale = 0, and compute a solution to A*x = 0. +* + DO 100 I = 1, N + X( I ) = ZERO + 100 CONTINUE + X( J ) = ONE + XJ = ONE + SCALE = ZERO + XMAX = ZERO + END IF + 110 CONTINUE +* +* Scale x if necessary to avoid overflow when adding a +* multiple of column j of A. +* + IF( XJ.GT.ONE ) THEN + REC = ONE / XJ + IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN +* +* Scale x by 1/(2*abs(x(j))). +* + REC = REC*HALF + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + END IF + ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN +* +* Scale x by 1/2. +* + CALL ZDSCAL( N, HALF, X, 1 ) + SCALE = SCALE*HALF + END IF +* + IF( UPPER ) THEN + IF( J.GT.1 ) THEN +* +* Compute the update +* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) +* + CALL ZAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, + $ 1 ) + I = IZAMAX( J-1, X, 1 ) + XMAX = CABS1( X( I ) ) + END IF + ELSE + IF( J.LT.N ) THEN +* +* Compute the update +* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) +* + CALL ZAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, + $ X( J+1 ), 1 ) + I = J + IZAMAX( N-J, X( J+1 ), 1 ) + XMAX = CABS1( X( I ) ) + END IF + END IF + 120 CONTINUE +* + ELSE IF( LSAME( TRANS, 'T' ) ) THEN +* +* Solve A**T * x = b +* + DO 170 J = JFIRST, JLAST, JINC +* +* Compute x(j) = b(j) - sum A(k,j)*x(k). +* k<>j +* + XJ = CABS1( X( J ) ) + USCAL = TSCAL + REC = ONE / MAX( XMAX, ONE ) + IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN +* +* If x(j) could overflow, scale x by 1/(2*XMAX). +* + REC = REC*HALF + IF( NOUNIT ) THEN + TJJS = A( J, J )*TSCAL + ELSE + TJJS = TSCAL + END IF + TJJ = CABS1( TJJS ) + IF( TJJ.GT.ONE ) THEN +* +* Divide by A(j,j) when scaling x if A(j,j) > 1. +* + REC = MIN( ONE, REC*TJJ ) + USCAL = ZLADIV( USCAL, TJJS ) + END IF + IF( REC.LT.ONE ) THEN + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF +* + CSUMJ = ZERO + IF( USCAL.EQ.DCMPLX( ONE ) ) THEN +* +* If the scaling needed for A in the dot product is 1, +* call ZDOTU to perform the dot product. +* + IF( UPPER ) THEN + CSUMJ = ZDOTU( J-1, A( 1, J ), 1, X, 1 ) + ELSE IF( J.LT.N ) THEN + CSUMJ = ZDOTU( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) + END IF + ELSE +* +* Otherwise, use in-line code for the dot product. +* + IF( UPPER ) THEN + DO 130 I = 1, J - 1 + CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) + 130 CONTINUE + ELSE IF( J.LT.N ) THEN + DO 140 I = J + 1, N + CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) + 140 CONTINUE + END IF + END IF +* + IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN +* +* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) +* was not used to scale the dotproduct. +* + X( J ) = X( J ) - CSUMJ + XJ = CABS1( X( J ) ) + IF( NOUNIT ) THEN + TJJS = A( J, J )*TSCAL + ELSE + TJJS = TSCAL + IF( TSCAL.EQ.ONE ) + $ GO TO 160 + END IF +* +* Compute x(j) = x(j) / A(j,j), scaling if necessary. +* + TJJ = CABS1( TJJS ) + IF( TJJ.GT.SMLNUM ) THEN +* +* abs(A(j,j)) > SMLNUM: +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale X by 1/abs(x(j)). +* + REC = ONE / XJ + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + X( J ) = ZLADIV( X( J ), TJJS ) + ELSE IF( TJJ.GT.ZERO ) THEN +* +* 0 < abs(A(j,j)) <= SMLNUM: +* + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. +* + REC = ( TJJ*BIGNUM ) / XJ + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + X( J ) = ZLADIV( 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**T *x = 0. +* + DO 150 I = 1, N + X( I ) = ZERO + 150 CONTINUE + X( J ) = ONE + SCALE = ZERO + XMAX = ZERO + END IF + 160 CONTINUE + ELSE +* +* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot +* product has already been divided by 1/A(j,j). +* + X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ + END IF + XMAX = MAX( XMAX, CABS1( X( J ) ) ) + 170 CONTINUE +* + ELSE +* +* Solve A**H * x = b +* + DO 220 J = JFIRST, JLAST, JINC +* +* Compute x(j) = b(j) - sum A(k,j)*x(k). +* k<>j +* + XJ = CABS1( X( J ) ) + USCAL = TSCAL + REC = ONE / MAX( XMAX, ONE ) + IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN +* +* If x(j) could overflow, scale x by 1/(2*XMAX). +* + REC = REC*HALF + IF( NOUNIT ) THEN + TJJS = DCONJG( A( J, J ) )*TSCAL + ELSE + TJJS = TSCAL + END IF + TJJ = CABS1( TJJS ) + IF( TJJ.GT.ONE ) THEN +* +* Divide by A(j,j) when scaling x if A(j,j) > 1. +* + REC = MIN( ONE, REC*TJJ ) + USCAL = ZLADIV( USCAL, TJJS ) + END IF + IF( REC.LT.ONE ) THEN + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF +* + CSUMJ = ZERO + IF( USCAL.EQ.DCMPLX( ONE ) ) THEN +* +* If the scaling needed for A in the dot product is 1, +* call ZDOTC to perform the dot product. +* + IF( UPPER ) THEN + CSUMJ = ZDOTC( J-1, A( 1, J ), 1, X, 1 ) + ELSE IF( J.LT.N ) THEN + CSUMJ = ZDOTC( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) + END IF + ELSE +* +* Otherwise, use in-line code for the dot product. +* + IF( UPPER ) THEN + DO 180 I = 1, J - 1 + CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )* + $ X( I ) + 180 CONTINUE + ELSE IF( J.LT.N ) THEN + DO 190 I = J + 1, N + CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )* + $ X( I ) + 190 CONTINUE + END IF + END IF +* + IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN +* +* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) +* was not used to scale the dotproduct. +* + X( J ) = X( J ) - CSUMJ + XJ = CABS1( X( J ) ) + IF( NOUNIT ) THEN + TJJS = DCONJG( A( J, J ) )*TSCAL + ELSE + TJJS = TSCAL + IF( TSCAL.EQ.ONE ) + $ GO TO 210 + END IF +* +* Compute x(j) = x(j) / A(j,j), scaling if necessary. +* + TJJ = CABS1( TJJS ) + IF( TJJ.GT.SMLNUM ) THEN +* +* abs(A(j,j)) > SMLNUM: +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale X by 1/abs(x(j)). +* + REC = ONE / XJ + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + X( J ) = ZLADIV( X( J ), TJJS ) + ELSE IF( TJJ.GT.ZERO ) THEN +* +* 0 < abs(A(j,j)) <= SMLNUM: +* + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. +* + REC = ( TJJ*BIGNUM ) / XJ + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + X( J ) = ZLADIV( 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**H *x = 0. +* + DO 200 I = 1, N + X( I ) = ZERO + 200 CONTINUE + X( J ) = ONE + SCALE = ZERO + XMAX = ZERO + END IF + 210 CONTINUE + ELSE +* +* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot +* product has already been divided by 1/A(j,j). +* + X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ + END IF + XMAX = MAX( XMAX, CABS1( X( J ) ) ) + 220 CONTINUE + END IF + SCALE = SCALE / TSCAL + END IF +* +* Scale the column norms by 1/TSCAL for return. +* + IF( TSCAL.NE.ONE ) THEN + CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) + END IF +* + RETURN +* +* End of ZLATRS +* + END diff --git a/2.3-1/src/fortran/lapack/zlatrz.f b/2.3-1/src/fortran/lapack/zlatrz.f new file mode 100644 index 00000000..c1c7aab3 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zlatrz.f @@ -0,0 +1,133 @@ + SUBROUTINE ZLATRZ( M, N, L, A, LDA, TAU, WORK ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER L, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I + COMPLEX*16 ALPHA +* .. +* .. External Subroutines .. + EXTERNAL ZLACGV, ZLARFG, ZLARZ +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.EQ.0 ) THEN + RETURN + ELSE IF( M.EQ.N ) THEN + DO 10 I = 1, N + TAU( I ) = ZERO + 10 CONTINUE + RETURN + END IF +* + DO 20 I = M, 1, -1 +* +* Generate elementary reflector H(i) to annihilate +* [ A(i,i) A(i,n-l+1:n) ] +* + CALL ZLACGV( L, A( I, N-L+1 ), LDA ) + ALPHA = DCONJG( A( I, I ) ) + CALL ZLARFG( L+1, ALPHA, A( I, N-L+1 ), LDA, TAU( I ) ) + TAU( I ) = DCONJG( TAU( I ) ) +* +* Apply H(i) to A(1:i-1,i:n) from the right +* + CALL ZLARZ( 'Right', I-1, N-I+1, L, A( I, N-L+1 ), LDA, + $ DCONJG( TAU( I ) ), A( 1, I ), LDA, WORK ) + A( I, I ) = DCONJG( ALPHA ) +* + 20 CONTINUE +* + RETURN +* +* End of ZLATRZ +* + END diff --git a/2.3-1/src/fortran/lapack/zpotf2.f b/2.3-1/src/fortran/lapack/zpotf2.f new file mode 100644 index 00000000..ca9df447 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zpotf2.f @@ -0,0 +1,174 @@ + SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J + DOUBLE PRECISION AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + COMPLEX*16 ZDOTC + EXTERNAL LSAME, ZDOTC +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZDSCAL, ZGEMV, ZLACGV +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZPOTF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization A = U'*U. +* + DO 10 J = 1, N +* +* Compute U(J,J) and test for non-positive-definiteness. +* + AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( 1, J ), 1, + $ A( 1, J ), 1 ) + IF( AJJ.LE.ZERO ) THEN + A( J, J ) = AJJ + GO TO 30 + END IF + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of row J. +* + IF( J.LT.N ) THEN + CALL ZLACGV( J-1, A( 1, J ), 1 ) + CALL ZGEMV( 'Transpose', J-1, N-J, -CONE, A( 1, J+1 ), + $ LDA, A( 1, J ), 1, CONE, A( J, J+1 ), LDA ) + CALL ZLACGV( J-1, A( 1, J ), 1 ) + CALL ZDSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) + END IF + 10 CONTINUE + ELSE +* +* Compute the Cholesky factorization A = L*L'. +* + DO 20 J = 1, N +* +* Compute L(J,J) and test for non-positive-definiteness. +* + AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( J, 1 ), LDA, + $ A( J, 1 ), LDA ) + IF( AJJ.LE.ZERO ) THEN + A( J, J ) = AJJ + GO TO 30 + END IF + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of column J. +* + IF( J.LT.N ) THEN + CALL ZLACGV( J-1, A( J, 1 ), LDA ) + CALL ZGEMV( 'No transpose', N-J, J-1, -CONE, A( J+1, 1 ), + $ LDA, A( J, 1 ), LDA, CONE, A( J+1, J ), 1 ) + CALL ZLACGV( J-1, A( J, 1 ), LDA ) + CALL ZDSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) + END IF + 20 CONTINUE + END IF + GO TO 40 +* + 30 CONTINUE + INFO = J +* + 40 CONTINUE + RETURN +* +* End of ZPOTF2 +* + END diff --git a/2.3-1/src/fortran/lapack/zpotrf.f b/2.3-1/src/fortran/lapack/zpotrf.f new file mode 100644 index 00000000..86772608 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zpotrf.f @@ -0,0 +1,186 @@ + SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + COMPLEX*16 CONE + PARAMETER ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, JB, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGEMM, ZHERK, ZPOTF2, ZTRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZPOTRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'ZPOTRF', UPLO, N, -1, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code. +* + CALL ZPOTF2( UPLO, N, A, LDA, INFO ) + ELSE +* +* Use blocked code. +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization A = U'*U. +* + DO 10 J = 1, N, NB +* +* Update and factorize the current diagonal block and test +* for non-positive-definiteness. +* + JB = MIN( NB, N-J+1 ) + CALL ZHERK( 'Upper', 'Conjugate transpose', JB, J-1, + $ -ONE, A( 1, J ), LDA, ONE, A( J, J ), LDA ) + CALL ZPOTF2( 'Upper', JB, A( J, J ), LDA, INFO ) + IF( INFO.NE.0 ) + $ GO TO 30 + IF( J+JB.LE.N ) THEN +* +* Compute the current block row. +* + CALL ZGEMM( 'Conjugate transpose', 'No transpose', JB, + $ N-J-JB+1, J-1, -CONE, A( 1, J ), LDA, + $ A( 1, J+JB ), LDA, CONE, A( J, J+JB ), + $ LDA ) + CALL ZTRSM( 'Left', 'Upper', 'Conjugate transpose', + $ 'Non-unit', JB, N-J-JB+1, CONE, A( J, J ), + $ LDA, A( J, J+JB ), LDA ) + END IF + 10 CONTINUE +* + ELSE +* +* Compute the Cholesky factorization A = L*L'. +* + DO 20 J = 1, N, NB +* +* Update and factorize the current diagonal block and test +* for non-positive-definiteness. +* + JB = MIN( NB, N-J+1 ) + CALL ZHERK( 'Lower', 'No transpose', JB, J-1, -ONE, + $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) + CALL ZPOTF2( 'Lower', JB, A( J, J ), LDA, INFO ) + IF( INFO.NE.0 ) + $ GO TO 30 + IF( J+JB.LE.N ) THEN +* +* Compute the current block column. +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ N-J-JB+1, JB, J-1, -CONE, A( J+JB, 1 ), + $ LDA, A( J, 1 ), LDA, CONE, A( J+JB, J ), + $ LDA ) + CALL ZTRSM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Non-unit', N-J-JB+1, JB, CONE, A( J, J ), + $ LDA, A( J+JB, J ), LDA ) + END IF + 20 CONTINUE + END IF + END IF + GO TO 40 +* + 30 CONTINUE + INFO = INFO + J - 1 +* + 40 CONTINUE + RETURN +* +* End of ZPOTRF +* + END diff --git a/2.3-1/src/fortran/lapack/zrot.f b/2.3-1/src/fortran/lapack/zrot.f new file mode 100644 index 00000000..9c548e23 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zrot.f @@ -0,0 +1,91 @@ + SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, INCY, N + DOUBLE PRECISION C + COMPLEX*16 S +* .. +* .. Array Arguments .. + COMPLEX*16 CX( * ), CY( * ) +* .. +* +* 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 .. + INTEGER I, IX, IY + COMPLEX*16 STEMP +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* .. Executable Statements .. +* + IF( N.LE.0 ) + $ RETURN + IF( INCX.EQ.1 .AND. INCY.EQ.1 ) + $ GO TO 20 +* +* Code for unequal increments or equal increments not equal to 1 +* + IX = 1 + IY = 1 + IF( INCX.LT.0 ) + $ IX = ( -N+1 )*INCX + 1 + IF( INCY.LT.0 ) + $ IY = ( -N+1 )*INCY + 1 + DO 10 I = 1, N + STEMP = C*CX( IX ) + S*CY( IY ) + CY( IY ) = C*CY( IY ) - DCONJG( S )*CX( IX ) + CX( IX ) = STEMP + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +* +* Code for both increments equal to 1 +* + 20 CONTINUE + DO 30 I = 1, N + STEMP = C*CX( I ) + S*CY( I ) + CY( I ) = C*CY( I ) - DCONJG( S )*CX( I ) + CX( I ) = STEMP + 30 CONTINUE + RETURN + END diff --git a/2.3-1/src/fortran/lapack/zsteqr.f b/2.3-1/src/fortran/lapack/zsteqr.f new file mode 100644 index 00000000..a72fdd96 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zsteqr.f @@ -0,0 +1,503 @@ + SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER COMPZ + INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ), WORK( * ) + COMPLEX*16 Z( LDZ, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), + $ CONE = ( 1.0D0, 0.0D0 ) ) + INTEGER MAXIT + PARAMETER ( MAXIT = 30 ) +* .. +* .. Local Scalars .. + INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, + $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, + $ NM1, NMAXIT + DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, + $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 + EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA, + $ ZLASET, ZLASR, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( LSAME( COMPZ, 'N' ) ) THEN + ICOMPZ = 0 + ELSE IF( LSAME( COMPZ, 'V' ) ) THEN + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ICOMPZ = 2 + ELSE + ICOMPZ = -1 + END IF + IF( ICOMPZ.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, + $ N ) ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSTEQR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( ICOMPZ.EQ.2 ) + $ Z( 1, 1 ) = CONE + RETURN + END IF +* +* Determine the unit roundoff and over/underflow thresholds. +* + EPS = DLAMCH( 'E' ) + EPS2 = EPS**2 + SAFMIN = DLAMCH( 'S' ) + SAFMAX = ONE / SAFMIN + SSFMAX = SQRT( SAFMAX ) / THREE + SSFMIN = SQRT( SAFMIN ) / EPS2 +* +* Compute the eigenvalues and eigenvectors of the tridiagonal +* matrix. +* + IF( ICOMPZ.EQ.2 ) + $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) +* + NMAXIT = N*MAXIT + 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 +* + 10 CONTINUE + IF( L1.GT.N ) + $ GO TO 160 + IF( L1.GT.1 ) + $ E( L1-1 ) = ZERO + IF( L1.LE.NM1 ) THEN + DO 20 M = L1, NM1 + TST = ABS( E( M ) ) + IF( TST.EQ.ZERO ) + $ GO TO 30 + IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ + $ 1 ) ) ) )*EPS ) THEN + E( M ) = ZERO + GO TO 30 + END IF + 20 CONTINUE + END IF + M = N +* + 30 CONTINUE + L = L1 + LSV = L + LEND = M + LENDSV = LEND + L1 = M + 1 + IF( LEND.EQ.L ) + $ GO TO 10 +* +* Scale submatrix in rows and columns L to LEND +* + ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) + ISCALE = 0 + IF( ANORM.EQ.ZERO ) + $ GO TO 10 + IF( ANORM.GT.SSFMAX ) THEN + ISCALE = 1 + CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, + $ INFO ) + CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, + $ INFO ) + ELSE IF( ANORM.LT.SSFMIN ) THEN + ISCALE = 2 + CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, + $ INFO ) + CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, + $ INFO ) + END IF +* +* Choose between QL and QR iteration +* + IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN + LEND = LSV + L = LENDSV + END IF +* + IF( LEND.GT.L ) THEN +* +* QL Iteration +* +* Look for small subdiagonal element. +* + 40 CONTINUE + IF( L.NE.LEND ) THEN + LENDM1 = LEND - 1 + DO 50 M = L, LENDM1 + TST = ABS( E( M ) )**2 + IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ + $ SAFMIN )GO TO 60 + 50 CONTINUE + END IF +* + M = LEND +* + 60 CONTINUE + IF( M.LT.LEND ) + $ E( M ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 80 +* +* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 +* to compute its eigensystem. +* + IF( M.EQ.L+1 ) THEN + IF( ICOMPZ.GT.0 ) THEN + CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) + WORK( L ) = C + WORK( N-1+L ) = S + CALL ZLASR( 'R', 'V', 'B', N, 2, WORK( L ), + $ WORK( N-1+L ), Z( 1, L ), LDZ ) + ELSE + CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) + END IF + D( L ) = RT1 + D( L+1 ) = RT2 + E( L ) = ZERO + L = L + 2 + IF( L.LE.LEND ) + $ GO TO 40 + GO TO 140 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 140 + JTOT = JTOT + 1 +* +* Form shift. +* + G = ( D( L+1 )-P ) / ( TWO*E( L ) ) + R = DLAPY2( G, ONE ) + G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) +* + S = ONE + C = ONE + P = ZERO +* +* Inner loop +* + MM1 = M - 1 + DO 70 I = MM1, L, -1 + F = S*E( I ) + B = C*E( I ) + CALL DLARTG( G, F, C, S, R ) + IF( I.NE.M-1 ) + $ E( I+1 ) = R + G = D( I+1 ) - P + R = ( D( I )-G )*S + TWO*C*B + P = S*R + D( I+1 ) = G + P + G = C*R - B +* +* If eigenvectors are desired, then save rotations. +* + IF( ICOMPZ.GT.0 ) THEN + WORK( I ) = C + WORK( N-1+I ) = -S + END IF +* + 70 CONTINUE +* +* If eigenvectors are desired, then apply saved rotations. +* + IF( ICOMPZ.GT.0 ) THEN + MM = M - L + 1 + CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), + $ Z( 1, L ), LDZ ) + END IF +* + D( L ) = D( L ) - P + E( L ) = G + GO TO 40 +* +* Eigenvalue found. +* + 80 CONTINUE + D( L ) = P +* + L = L + 1 + IF( L.LE.LEND ) + $ GO TO 40 + GO TO 140 +* + ELSE +* +* QR Iteration +* +* Look for small superdiagonal element. +* + 90 CONTINUE + IF( L.NE.LEND ) THEN + LENDP1 = LEND + 1 + DO 100 M = L, LENDP1, -1 + TST = ABS( E( M-1 ) )**2 + IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ + $ SAFMIN )GO TO 110 + 100 CONTINUE + END IF +* + M = LEND +* + 110 CONTINUE + IF( M.GT.LEND ) + $ E( M-1 ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 130 +* +* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 +* to compute its eigensystem. +* + IF( M.EQ.L-1 ) THEN + IF( ICOMPZ.GT.0 ) THEN + CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) + WORK( M ) = C + WORK( N-1+M ) = S + CALL ZLASR( 'R', 'V', 'F', N, 2, WORK( M ), + $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) + ELSE + CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) + END IF + D( L-1 ) = RT1 + D( L ) = RT2 + E( L-1 ) = ZERO + L = L - 2 + IF( L.GE.LEND ) + $ GO TO 90 + GO TO 140 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 140 + JTOT = JTOT + 1 +* +* Form shift. +* + G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) + R = DLAPY2( G, ONE ) + G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) +* + S = ONE + C = ONE + P = ZERO +* +* Inner loop +* + LM1 = L - 1 + DO 120 I = M, LM1 + F = S*E( I ) + B = C*E( I ) + CALL DLARTG( G, F, C, S, R ) + IF( I.NE.M ) + $ E( I-1 ) = R + G = D( I ) - P + R = ( D( I+1 )-G )*S + TWO*C*B + P = S*R + D( I ) = G + P + G = C*R - B +* +* If eigenvectors are desired, then save rotations. +* + IF( ICOMPZ.GT.0 ) THEN + WORK( I ) = C + WORK( N-1+I ) = S + END IF +* + 120 CONTINUE +* +* If eigenvectors are desired, then apply saved rotations. +* + IF( ICOMPZ.GT.0 ) THEN + MM = L - M + 1 + CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), + $ Z( 1, M ), LDZ ) + END IF +* + D( L ) = D( L ) - P + E( LM1 ) = G + GO TO 90 +* +* Eigenvalue found. +* + 130 CONTINUE + D( L ) = P +* + L = L - 1 + IF( L.GE.LEND ) + $ GO TO 90 + GO TO 140 +* + END IF +* +* Undo scaling if necessary +* + 140 CONTINUE + IF( ISCALE.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, + $ D( LSV ), N, INFO ) + CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), + $ N, INFO ) + ELSE IF( ISCALE.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, + $ D( LSV ), N, INFO ) + CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), + $ N, INFO ) + END IF +* +* Check for no convergence to an eigenvalue after a total +* of N*MAXIT iterations. +* + IF( JTOT.EQ.NMAXIT ) THEN + DO 150 I = 1, N - 1 + IF( E( I ).NE.ZERO ) + $ INFO = INFO + 1 + 150 CONTINUE + RETURN + END IF + GO TO 10 +* +* Order eigenvalues and eigenvectors. +* + 160 CONTINUE + IF( ICOMPZ.EQ.0 ) THEN +* +* Use Quick Sort +* + CALL DLASRT( 'I', N, D, INFO ) +* + ELSE +* +* Use Selection Sort to minimize swaps of eigenvectors +* + DO 180 II = 2, N + I = II - 1 + K = I + P = D( I ) + DO 170 J = II, N + IF( D( J ).LT.P ) THEN + K = J + P = D( J ) + END IF + 170 CONTINUE + IF( K.NE.I ) THEN + D( K ) = D( I ) + D( I ) = P + CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) + END IF + 180 CONTINUE + END IF + RETURN +* +* End of ZSTEQR +* + END diff --git a/2.3-1/src/fortran/lapack/ztgevc.f b/2.3-1/src/fortran/lapack/ztgevc.f new file mode 100644 index 00000000..b8da962d --- /dev/null +++ b/2.3-1/src/fortran/lapack/ztgevc.f @@ -0,0 +1,633 @@ + SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, + $ LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER HOWMNY, SIDE + INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 P( LDP, * ), S( LDS, * ), VL( LDVL, * ), + $ VR( LDVR, * ), WORK( * ) +* .. +* +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL COMPL, COMPR, ILALL, ILBACK, ILBBAD, ILCOMP, + $ LSA, LSB + INTEGER I, IBEG, IEIG, IEND, IHWMNY, IM, ISIDE, ISRC, + $ J, JE, JR + DOUBLE PRECISION ACOEFA, ACOEFF, ANORM, ASCALE, BCOEFA, BIG, + $ BIGNUM, BNORM, BSCALE, DMIN, SAFMIN, SBETA, + $ SCALE, SMALL, TEMP, ULP, XMAX + COMPLEX*16 BCOEFF, CA, CB, D, SALPHA, SUM, SUMA, SUMB, X +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + COMPLEX*16 ZLADIV + EXTERNAL LSAME, DLAMCH, ZLADIV +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, XERBLA, ZGEMV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION ABS1 +* .. +* .. Statement Function definitions .. + ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) ) +* .. +* .. Executable Statements .. +* +* Decode and Test the input parameters +* + IF( LSAME( HOWMNY, 'A' ) ) THEN + IHWMNY = 1 + ILALL = .TRUE. + ILBACK = .FALSE. + ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN + IHWMNY = 2 + ILALL = .FALSE. + ILBACK = .FALSE. + ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN + IHWMNY = 3 + ILALL = .TRUE. + ILBACK = .TRUE. + ELSE + IHWMNY = -1 + END IF +* + IF( LSAME( SIDE, 'R' ) ) THEN + ISIDE = 1 + COMPL = .FALSE. + COMPR = .TRUE. + ELSE IF( LSAME( SIDE, 'L' ) ) THEN + ISIDE = 2 + COMPL = .TRUE. + COMPR = .FALSE. + ELSE IF( LSAME( SIDE, 'B' ) ) THEN + ISIDE = 3 + COMPL = .TRUE. + COMPR = .TRUE. + ELSE + ISIDE = -1 + END IF +* + INFO = 0 + IF( ISIDE.LT.0 ) THEN + INFO = -1 + ELSE IF( IHWMNY.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDP.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTGEVC', -INFO ) + RETURN + END IF +* +* Count the number of eigenvectors +* + IF( .NOT.ILALL ) THEN + IM = 0 + DO 10 J = 1, N + IF( SELECT( J ) ) + $ IM = IM + 1 + 10 CONTINUE + ELSE + IM = N + END IF +* +* Check diagonal of B +* + ILBBAD = .FALSE. + DO 20 J = 1, N + IF( DIMAG( P( J, J ) ).NE.ZERO ) + $ ILBBAD = .TRUE. + 20 CONTINUE +* + IF( ILBBAD ) THEN + INFO = -7 + ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN + INFO = -10 + ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN + INFO = -12 + ELSE IF( MM.LT.IM ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTGEVC', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + M = IM + IF( N.EQ.0 ) + $ RETURN +* +* Machine Constants +* + SAFMIN = DLAMCH( 'Safe minimum' ) + BIG = ONE / SAFMIN + CALL DLABAD( SAFMIN, BIG ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + SMALL = SAFMIN*N / ULP + BIG = ONE / SMALL + BIGNUM = ONE / ( 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. +* + ANORM = ABS1( S( 1, 1 ) ) + BNORM = ABS1( P( 1, 1 ) ) + RWORK( 1 ) = ZERO + RWORK( N+1 ) = ZERO + DO 40 J = 2, N + RWORK( J ) = ZERO + RWORK( N+J ) = ZERO + DO 30 I = 1, J - 1 + RWORK( J ) = RWORK( J ) + ABS1( S( I, J ) ) + RWORK( N+J ) = RWORK( N+J ) + ABS1( P( I, J ) ) + 30 CONTINUE + ANORM = MAX( ANORM, RWORK( J )+ABS1( S( J, J ) ) ) + BNORM = MAX( BNORM, RWORK( N+J )+ABS1( P( J, J ) ) ) + 40 CONTINUE +* + ASCALE = ONE / MAX( ANORM, SAFMIN ) + BSCALE = ONE / MAX( BNORM, SAFMIN ) +* +* Left eigenvectors +* + IF( COMPL ) THEN + IEIG = 0 +* +* Main loop over eigenvalues +* + DO 140 JE = 1, N + IF( ILALL ) THEN + ILCOMP = .TRUE. + ELSE + ILCOMP = SELECT( JE ) + END IF + IF( ILCOMP ) THEN + IEIG = IEIG + 1 +* + IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( DBLE( P( JE, JE ) ) ).LE.SAFMIN ) THEN +* +* Singular matrix pencil -- return unit eigenvector +* + DO 50 JR = 1, N + VL( JR, IEIG ) = CZERO + 50 CONTINUE + VL( IEIG, IEIG ) = CONE + GO TO 140 + END IF +* +* Non-singular eigenvalue: +* Compute coefficients a and b in +* H +* y ( a A - b B ) = 0 +* + TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE, + $ ABS( DBLE( P( JE, JE ) ) )*BSCALE, SAFMIN ) + SALPHA = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*DBLE( P( JE, JE ) ) )*BSCALE + ACOEFF = SBETA*ASCALE + BCOEFF = SALPHA*BSCALE +* +* Scale to avoid underflow +* + LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL + LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT. + $ SMALL +* + SCALE = ONE + IF( LSA ) + $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) + IF( LSB ) + $ SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )* + $ MIN( BNORM, BIG ) ) + IF( LSA .OR. LSB ) THEN + SCALE = MIN( SCALE, ONE / + $ ( SAFMIN*MAX( ONE, ABS( ACOEFF ), + $ ABS1( BCOEFF ) ) ) ) + IF( LSA ) THEN + ACOEFF = ASCALE*( SCALE*SBETA ) + ELSE + ACOEFF = SCALE*ACOEFF + END IF + IF( LSB ) THEN + BCOEFF = BSCALE*( SCALE*SALPHA ) + ELSE + BCOEFF = SCALE*BCOEFF + END IF + END IF +* + ACOEFA = ABS( ACOEFF ) + BCOEFA = ABS1( BCOEFF ) + XMAX = ONE + DO 60 JR = 1, N + WORK( JR ) = CZERO + 60 CONTINUE + WORK( JE ) = CONE + DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, 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) +* + DO 100 J = JE + 1, N +* +* Compute +* j-1 +* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) +* k=je +* (Scale if necessary) +* + TEMP = ONE / XMAX + IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GT.BIGNUM* + $ TEMP ) THEN + DO 70 JR = JE, J - 1 + WORK( JR ) = TEMP*WORK( JR ) + 70 CONTINUE + XMAX = ONE + END IF + SUMA = CZERO + SUMB = CZERO +* + DO 80 JR = JE, J - 1 + SUMA = SUMA + DCONJG( S( JR, J ) )*WORK( JR ) + SUMB = SUMB + DCONJG( P( JR, J ) )*WORK( JR ) + 80 CONTINUE + SUM = ACOEFF*SUMA - DCONJG( BCOEFF )*SUMB +* +* Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) ) +* +* with scaling and perturbation of the denominator +* + D = DCONJG( ACOEFF*S( J, J )-BCOEFF*P( J, J ) ) + IF( ABS1( D ).LE.DMIN ) + $ D = DCMPLX( DMIN ) +* + IF( ABS1( D ).LT.ONE ) THEN + IF( ABS1( SUM ).GE.BIGNUM*ABS1( D ) ) THEN + TEMP = ONE / ABS1( SUM ) + DO 90 JR = JE, J - 1 + WORK( JR ) = TEMP*WORK( JR ) + 90 CONTINUE + XMAX = TEMP*XMAX + SUM = TEMP*SUM + END IF + END IF + WORK( J ) = ZLADIV( -SUM, D ) + XMAX = MAX( XMAX, ABS1( WORK( J ) ) ) + 100 CONTINUE +* +* Back transform eigenvector if HOWMNY='B'. +* + IF( ILBACK ) THEN + CALL ZGEMV( 'N', N, N+1-JE, CONE, VL( 1, JE ), LDVL, + $ WORK( JE ), 1, CZERO, WORK( N+1 ), 1 ) + ISRC = 2 + IBEG = 1 + ELSE + ISRC = 1 + IBEG = JE + END IF +* +* Copy and scale eigenvector into column of VL +* + XMAX = ZERO + DO 110 JR = IBEG, N + XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) ) + 110 CONTINUE +* + IF( XMAX.GT.SAFMIN ) THEN + TEMP = ONE / XMAX + DO 120 JR = IBEG, N + VL( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR ) + 120 CONTINUE + ELSE + IBEG = N + 1 + END IF +* + DO 130 JR = 1, IBEG - 1 + VL( JR, IEIG ) = CZERO + 130 CONTINUE +* + END IF + 140 CONTINUE + END IF +* +* Right eigenvectors +* + IF( COMPR ) THEN + IEIG = IM + 1 +* +* Main loop over eigenvalues +* + DO 250 JE = N, 1, -1 + IF( ILALL ) THEN + ILCOMP = .TRUE. + ELSE + ILCOMP = SELECT( JE ) + END IF + IF( ILCOMP ) THEN + IEIG = IEIG - 1 +* + IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( DBLE( P( JE, JE ) ) ).LE.SAFMIN ) THEN +* +* Singular matrix pencil -- return unit eigenvector +* + DO 150 JR = 1, N + VR( JR, IEIG ) = CZERO + 150 CONTINUE + VR( IEIG, IEIG ) = CONE + GO TO 250 + END IF +* +* Non-singular eigenvalue: +* Compute coefficients a and b in +* +* ( a A - b B ) x = 0 +* + TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE, + $ ABS( DBLE( P( JE, JE ) ) )*BSCALE, SAFMIN ) + SALPHA = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*DBLE( P( JE, JE ) ) )*BSCALE + ACOEFF = SBETA*ASCALE + BCOEFF = SALPHA*BSCALE +* +* Scale to avoid underflow +* + LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL + LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT. + $ SMALL +* + SCALE = ONE + IF( LSA ) + $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) + IF( LSB ) + $ SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )* + $ MIN( BNORM, BIG ) ) + IF( LSA .OR. LSB ) THEN + SCALE = MIN( SCALE, ONE / + $ ( SAFMIN*MAX( ONE, ABS( ACOEFF ), + $ ABS1( BCOEFF ) ) ) ) + IF( LSA ) THEN + ACOEFF = ASCALE*( SCALE*SBETA ) + ELSE + ACOEFF = SCALE*ACOEFF + END IF + IF( LSB ) THEN + BCOEFF = BSCALE*( SCALE*SALPHA ) + ELSE + BCOEFF = SCALE*BCOEFF + END IF + END IF +* + ACOEFA = ABS( ACOEFF ) + BCOEFA = ABS1( BCOEFF ) + XMAX = ONE + DO 160 JR = 1, N + WORK( JR ) = CZERO + 160 CONTINUE + WORK( JE ) = CONE + DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN ) +* +* Triangular solve of (a A - b B) x = 0 (columnwise) +* +* WORK(1:j-1) contains sums w, +* WORK(j+1:JE) contains x +* + DO 170 JR = 1, JE - 1 + WORK( JR ) = ACOEFF*S( JR, JE ) - BCOEFF*P( JR, JE ) + 170 CONTINUE + WORK( JE ) = CONE +* + DO 210 J = JE - 1, 1, -1 +* +* Form x(j) := - w(j) / d +* with scaling and perturbation of the denominator +* + D = ACOEFF*S( J, J ) - BCOEFF*P( J, J ) + IF( ABS1( D ).LE.DMIN ) + $ D = DCMPLX( DMIN ) +* + IF( ABS1( D ).LT.ONE ) THEN + IF( ABS1( WORK( J ) ).GE.BIGNUM*ABS1( D ) ) THEN + TEMP = ONE / ABS1( WORK( J ) ) + DO 180 JR = 1, JE + WORK( JR ) = TEMP*WORK( JR ) + 180 CONTINUE + END IF + END IF +* + WORK( J ) = ZLADIV( -WORK( J ), D ) +* + IF( J.GT.1 ) THEN +* +* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling +* + IF( ABS1( WORK( J ) ).GT.ONE ) THEN + TEMP = ONE / ABS1( WORK( J ) ) + IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GE. + $ BIGNUM*TEMP ) THEN + DO 190 JR = 1, JE + WORK( JR ) = TEMP*WORK( JR ) + 190 CONTINUE + END IF + END IF +* + CA = ACOEFF*WORK( J ) + CB = BCOEFF*WORK( J ) + DO 200 JR = 1, J - 1 + WORK( JR ) = WORK( JR ) + CA*S( JR, J ) - + $ CB*P( JR, J ) + 200 CONTINUE + END IF + 210 CONTINUE +* +* Back transform eigenvector if HOWMNY='B'. +* + IF( ILBACK ) THEN + CALL ZGEMV( 'N', N, JE, CONE, VR, LDVR, WORK, 1, + $ CZERO, WORK( N+1 ), 1 ) + ISRC = 2 + IEND = N + ELSE + ISRC = 1 + IEND = JE + END IF +* +* Copy and scale eigenvector into column of VR +* + XMAX = ZERO + DO 220 JR = 1, IEND + XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) ) + 220 CONTINUE +* + IF( XMAX.GT.SAFMIN ) THEN + TEMP = ONE / XMAX + DO 230 JR = 1, IEND + VR( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR ) + 230 CONTINUE + ELSE + IEND = 0 + END IF +* + DO 240 JR = IEND + 1, N + VR( JR, IEIG ) = CZERO + 240 CONTINUE +* + END IF + 250 CONTINUE + END IF +* + RETURN +* +* End of ZTGEVC +* + END diff --git a/2.3-1/src/fortran/lapack/ztgex2.f b/2.3-1/src/fortran/lapack/ztgex2.f new file mode 100644 index 00000000..a0c42aad --- /dev/null +++ b/2.3-1/src/fortran/lapack/ztgex2.f @@ -0,0 +1,265 @@ + SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, + $ LDZ, J1, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL WANTQ, WANTZ + INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), + $ Z( LDZ, * ) +* .. +* +* 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 .. + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION TEN + PARAMETER ( TEN = 10.0D+0 ) + INTEGER LDST + PARAMETER ( LDST = 2 ) + LOGICAL WANDS + PARAMETER ( WANDS = .TRUE. ) +* .. +* .. Local Scalars .. + LOGICAL DTRONG, WEAK + INTEGER I, M + DOUBLE PRECISION CQ, CZ, EPS, SA, SB, SCALE, SMLNUM, SS, SUM, + $ THRESH, WS + COMPLEX*16 CDUM, F, G, SQ, SZ +* .. +* .. Local Arrays .. + COMPLEX*16 S( LDST, LDST ), T( LDST, LDST ), WORK( 8 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL ZLACPY, ZLARTG, ZLASSQ, ZROT +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, MAX, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* + M = LDST + WEAK = .FALSE. + DTRONG = .FALSE. +* +* Make a local copy of selected block in (A, B) +* + CALL ZLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST ) + CALL ZLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST ) +* +* Compute the threshold for testing the acceptance of swapping. +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + SCALE = DBLE( CZERO ) + SUM = DBLE( CONE ) + CALL ZLACPY( 'Full', M, M, S, LDST, WORK, M ) + CALL ZLACPY( 'Full', M, M, T, LDST, WORK( M*M+1 ), M ) + CALL ZLASSQ( 2*M*M, WORK, 1, SCALE, SUM ) + SA = SCALE*SQRT( SUM ) + THRESH = MAX( TEN*EPS*SA, SMLNUM ) +* +* Compute unitary QL and RQ that swap 1-by-1 and 1-by-1 blocks +* using Givens rotations and perform the swap tentatively. +* + F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 ) + G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 ) + SA = ABS( S( 2, 2 ) ) + SB = ABS( T( 2, 2 ) ) + CALL ZLARTG( G, F, CZ, SZ, CDUM ) + SZ = -SZ + CALL ZROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, CZ, DCONJG( SZ ) ) + CALL ZROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, CZ, DCONJG( SZ ) ) + IF( SA.GE.SB ) THEN + CALL ZLARTG( S( 1, 1 ), S( 2, 1 ), CQ, SQ, CDUM ) + ELSE + CALL ZLARTG( T( 1, 1 ), T( 2, 1 ), CQ, SQ, CDUM ) + END IF + CALL ZROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, CQ, SQ ) + CALL ZROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, CQ, SQ ) +* +* Weak stability test: |S21| + |T21| <= O(EPS F-norm((S, T))) +* + WS = ABS( S( 2, 1 ) ) + ABS( T( 2, 1 ) ) + WEAK = WS.LE.THRESH + IF( .NOT.WEAK ) + $ GO TO 20 +* + IF( WANDS ) THEN +* +* Strong stability test: +* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A, B))) +* + CALL ZLACPY( 'Full', M, M, S, LDST, WORK, M ) + CALL ZLACPY( 'Full', M, M, T, LDST, WORK( M*M+1 ), M ) + CALL ZROT( 2, WORK, 1, WORK( 3 ), 1, CZ, -DCONJG( SZ ) ) + CALL ZROT( 2, WORK( 5 ), 1, WORK( 7 ), 1, CZ, -DCONJG( SZ ) ) + CALL ZROT( 2, WORK, 2, WORK( 2 ), 2, CQ, -SQ ) + CALL ZROT( 2, WORK( 5 ), 2, WORK( 6 ), 2, CQ, -SQ ) + DO 10 I = 1, 2 + WORK( I ) = WORK( I ) - A( J1+I-1, J1 ) + WORK( I+2 ) = WORK( I+2 ) - A( J1+I-1, J1+1 ) + WORK( I+4 ) = WORK( I+4 ) - B( J1+I-1, J1 ) + WORK( I+6 ) = WORK( I+6 ) - B( J1+I-1, J1+1 ) + 10 CONTINUE + SCALE = DBLE( CZERO ) + SUM = DBLE( CONE ) + CALL ZLASSQ( 2*M*M, WORK, 1, SCALE, SUM ) + SS = SCALE*SQRT( SUM ) + DTRONG = SS.LE.THRESH + IF( .NOT.DTRONG ) + $ GO TO 20 + END IF +* +* If the swap is accepted ("weakly" and "strongly"), apply the +* equivalence transformations to the original matrix pair (A,B) +* + CALL ZROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, CZ, + $ DCONJG( SZ ) ) + CALL ZROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, CZ, + $ DCONJG( SZ ) ) + CALL ZROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA, CQ, SQ ) + CALL ZROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB, CQ, SQ ) +* +* Set N1 by N2 (2,1) blocks to 0 +* + A( J1+1, J1 ) = CZERO + B( J1+1, J1 ) = CZERO +* +* Accumulate transformations into Q and Z if requested. +* + IF( WANTZ ) + $ CALL ZROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, CZ, + $ DCONJG( SZ ) ) + IF( WANTQ ) + $ CALL ZROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, CQ, + $ DCONJG( SQ ) ) +* +* Exit with INFO = 0 if swap was successfully performed. +* + RETURN +* +* Exit with INFO = 1 if swap was rejected. +* + 20 CONTINUE + INFO = 1 + RETURN +* +* End of ZTGEX2 +* + END diff --git a/2.3-1/src/fortran/lapack/ztgexc.f b/2.3-1/src/fortran/lapack/ztgexc.f new file mode 100644 index 00000000..0f57939c --- /dev/null +++ b/2.3-1/src/fortran/lapack/ztgexc.f @@ -0,0 +1,206 @@ + SUBROUTINE ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, + $ LDZ, IFST, ILST, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL WANTQ, WANTZ + INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), + $ Z( LDZ, * ) +* .. +* +* 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 .. + INTEGER HERE +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZTGEX2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Decode and test input arguments. + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. ( LDQ.LT.MAX( 1, N ) ) ) THEN + INFO = -9 + ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. ( LDZ.LT.MAX( 1, N ) ) ) THEN + INFO = -11 + ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN + INFO = -12 + ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTGEXC', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN + IF( IFST.EQ.ILST ) + $ RETURN +* + IF( IFST.LT.ILST ) THEN +* + HERE = IFST +* + 10 CONTINUE +* +* Swap with next one below +* + CALL ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, + $ HERE, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE + 1 + IF( HERE.LT.ILST ) + $ GO TO 10 + HERE = HERE - 1 + ELSE + HERE = IFST - 1 +* + 20 CONTINUE +* +* Swap with next one above +* + CALL ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, + $ HERE, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE - 1 + IF( HERE.GE.ILST ) + $ GO TO 20 + HERE = HERE + 1 + END IF + ILST = HERE + RETURN +* +* End of ZTGEXC +* + END diff --git a/2.3-1/src/fortran/lapack/ztgsen.f b/2.3-1/src/fortran/lapack/ztgsen.f new file mode 100644 index 00000000..71ee4cd0 --- /dev/null +++ b/2.3-1/src/fortran/lapack/ztgsen.f @@ -0,0 +1,652 @@ + SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, + $ ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, + $ WORK, LWORK, IWORK, LIWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* 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 .. + LOGICAL WANTQ, WANTZ + INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, + $ M, N + DOUBLE PRECISION PL, PR +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION DIF( * ) + COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), + $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* 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 .. + INTEGER IDIFJB + PARAMETER ( IDIFJB = 3 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, SWAP, WANTD, WANTD1, WANTD2, WANTP + INTEGER I, IERR, IJB, K, KASE, KS, LIWMIN, LWMIN, MN2, + $ N1, N2 + DOUBLE PRECISION DSCALE, DSUM, RDSCAL, SAFMIN +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLACN2, ZLACPY, ZLASSQ, ZSCAL, ZTGEXC, + $ ZTGSYL +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DCMPLX, DCONJG, MAX, SQRT +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN + INFO = -13 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -15 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTGSEN', -INFO ) + RETURN + END IF +* + IERR = 0 +* + WANTP = IJOB.EQ.1 .OR. IJOB.GE.4 + WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4 + WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5 + WANTD = WANTD1 .OR. WANTD2 +* +* Set M to the dimension of the specified pair of deflating +* subspaces. +* + M = 0 + DO 10 K = 1, N + ALPHA( K ) = A( K, K ) + BETA( K ) = B( K, K ) + IF( K.LT.N ) THEN + IF( SELECT( K ) ) + $ M = M + 1 + ELSE + IF( SELECT( N ) ) + $ M = M + 1 + END IF + 10 CONTINUE +* + IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN + LWMIN = MAX( 1, 2*M*( N-M ) ) + LIWMIN = MAX( 1, N+2 ) + ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN + LWMIN = MAX( 1, 4*M*( N-M ) ) + LIWMIN = MAX( 1, 2*M*( N-M ), N+2 ) + ELSE + LWMIN = 1 + LIWMIN = 1 + END IF +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -21 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -23 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTGSEN', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible. +* + IF( M.EQ.N .OR. M.EQ.0 ) THEN + IF( WANTP ) THEN + PL = ONE + PR = ONE + END IF + IF( WANTD ) THEN + DSCALE = ZERO + DSUM = ONE + DO 20 I = 1, N + CALL ZLASSQ( N, A( 1, I ), 1, DSCALE, DSUM ) + CALL ZLASSQ( N, B( 1, I ), 1, DSCALE, DSUM ) + 20 CONTINUE + DIF( 1 ) = DSCALE*SQRT( DSUM ) + DIF( 2 ) = DIF( 1 ) + END IF + GO TO 70 + END IF +* +* Get machine constant +* + SAFMIN = DLAMCH( 'S' ) +* +* Collect the selected blocks at the top-left corner of (A, B). +* + KS = 0 + DO 30 K = 1, N + SWAP = SELECT( K ) + IF( SWAP ) THEN + KS = KS + 1 +* +* Swap the K-th block to position KS. Compute unitary Q +* and Z that will swap adjacent diagonal blocks in (A, B). +* + IF( K.NE.KS ) + $ CALL ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, + $ LDZ, K, KS, IERR ) +* + IF( IERR.GT.0 ) THEN +* +* Swap is rejected: exit. +* + INFO = 1 + IF( WANTP ) THEN + PL = ZERO + PR = ZERO + END IF + IF( WANTD ) THEN + DIF( 1 ) = ZERO + DIF( 2 ) = ZERO + END IF + GO TO 70 + END IF + END IF + 30 CONTINUE + IF( WANTP ) THEN +* +* 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 + CALL ZLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 ) + CALL ZLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ), + $ N1 ) + IJB = 0 + CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, + $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1, + $ DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), + $ LWORK-2*N1*N2, IWORK, IERR ) +* +* Estimate the reciprocal of norms of "projections" onto +* left and right eigenspaces +* + RDSCAL = ZERO + DSUM = ONE + CALL ZLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM ) + PL = RDSCAL*SQRT( DSUM ) + IF( PL.EQ.ZERO ) THEN + PL = ONE + ELSE + PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) ) + END IF + RDSCAL = ZERO + DSUM = ONE + CALL ZLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM ) + PR = RDSCAL*SQRT( DSUM ) + IF( PR.EQ.ZERO ) THEN + PR = ONE + ELSE + PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) ) + END IF + END IF + IF( WANTD ) THEN +* +* Compute estimates Difu and Difl. +* + IF( WANTD1 ) THEN + N1 = M + N2 = N - M + I = N1 + 1 + IJB = IDIFJB +* +* Frobenius norm-based Difu estimate. +* + CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, + $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), + $ N1, DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), + $ LWORK-2*N1*N2, IWORK, IERR ) +* +* Frobenius norm-based Difl estimate. +* + CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK, + $ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ), + $ N2, DSCALE, DIF( 2 ), WORK( N1*N2*2+1 ), + $ LWORK-2*N1*N2, IWORK, 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 = 2*N1*N2 +* +* 1-norm-based estimate of Difu. +* + 40 CONTINUE + CALL ZLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 1 ), KASE, + $ ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN +* +* Solve generalized Sylvester equation +* + CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, + $ WORK, N1, B, LDB, B( I, I ), LDB, + $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), + $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, + $ IERR ) + ELSE +* +* Solve the transposed variant. +* + CALL ZTGSYL( 'C', IJB, N1, N2, A, LDA, A( I, I ), LDA, + $ WORK, N1, B, LDB, B( I, I ), LDB, + $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), + $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, + $ IERR ) + END IF + GO TO 40 + END IF + DIF( 1 ) = DSCALE / DIF( 1 ) +* +* 1-norm-based estimate of Difl. +* + 50 CONTINUE + CALL ZLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 2 ), KASE, + $ ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN +* +* Solve generalized Sylvester equation +* + CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, + $ WORK, N2, B( I, I ), LDB, B, LDB, + $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), + $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, + $ IERR ) + ELSE +* +* Solve the transposed variant. +* + CALL ZTGSYL( 'C', IJB, N2, N1, A( I, I ), LDA, A, LDA, + $ WORK, N2, B, LDB, B( I, I ), LDB, + $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), + $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, + $ IERR ) + END IF + GO TO 50 + END IF + DIF( 2 ) = DSCALE / DIF( 2 ) + END IF + END IF +* +* 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) +* + DO 60 K = 1, N + DSCALE = ABS( B( K, K ) ) + IF( DSCALE.GT.SAFMIN ) THEN + WORK( 1 ) = DCONJG( B( K, K ) / DSCALE ) + WORK( 2 ) = B( K, K ) / DSCALE + B( K, K ) = DSCALE + CALL ZSCAL( N-K, WORK( 1 ), B( K, K+1 ), LDB ) + CALL ZSCAL( N-K+1, WORK( 1 ), A( K, K ), LDA ) + IF( WANTQ ) + $ CALL ZSCAL( N, WORK( 2 ), Q( 1, K ), 1 ) + ELSE + B( K, K ) = DCMPLX( ZERO, ZERO ) + END IF +* + ALPHA( K ) = A( K, K ) + BETA( K ) = B( K, K ) +* + 60 CONTINUE +* + 70 CONTINUE +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of ZTGSEN +* + END diff --git a/2.3-1/src/fortran/lapack/ztgsy2.f b/2.3-1/src/fortran/lapack/ztgsy2.f new file mode 100644 index 00000000..82ec5eb1 --- /dev/null +++ b/2.3-1/src/fortran/lapack/ztgsy2.f @@ -0,0 +1,361 @@ + SUBROUTINE ZTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, + $ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, + $ INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N + DOUBLE PRECISION RDSCAL, RDSUM, SCALE +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), E( LDE, * ), F( LDF, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + INTEGER LDZ + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, LDZ = 2 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN + INTEGER I, IERR, J, K + DOUBLE PRECISION SCALOC + COMPLEX*16 ALPHA +* .. +* .. Local Arrays .. + INTEGER IPIV( LDZ ), JPIV( LDZ ) + COMPLEX*16 RHS( LDZ ), Z( LDZ, LDZ ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZAXPY, ZGESC2, ZGETC2, ZLATDF, ZSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC DCMPLX, DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Decode and test input parameters +* + INFO = 0 + IERR = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( NOTRAN ) THEN + IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN + INFO = -2 + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( M.LE.0 ) THEN + INFO = -3 + ELSE IF( N.LE.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, M ) ) THEN + INFO = -12 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -16 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTGSY2', -INFO ) + RETURN + END IF +* + IF( NOTRAN ) THEN +* +* 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 = ONE + SCALOC = ONE + DO 30 J = 1, N + DO 20 I = M, 1, -1 +* +* Build 2 by 2 system +* + Z( 1, 1 ) = A( I, I ) + Z( 2, 1 ) = D( I, I ) + Z( 1, 2 ) = -B( J, J ) + Z( 2, 2 ) = -E( J, J ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( I, J ) + RHS( 2 ) = F( I, J ) +* +* Solve Z * x = RHS +* + CALL ZGETC2( LDZ, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR + IF( IJOB.EQ.0 ) THEN + CALL ZGESC2( LDZ, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 10 K = 1, N + CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), + $ C( 1, K ), 1 ) + CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), + $ F( 1, K ), 1 ) + 10 CONTINUE + SCALE = SCALE*SCALOC + END IF + ELSE + CALL ZLATDF( IJOB, LDZ, Z, LDZ, RHS, RDSUM, RDSCAL, + $ IPIV, JPIV ) + END IF +* +* Unpack solution vector(s) +* + C( I, J ) = RHS( 1 ) + F( I, J ) = RHS( 2 ) +* +* Substitute R(I, J) and L(I, J) into remaining equation. +* + IF( I.GT.1 ) THEN + ALPHA = -RHS( 1 ) + CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, C( 1, J ), 1 ) + CALL ZAXPY( I-1, ALPHA, D( 1, I ), 1, F( 1, J ), 1 ) + END IF + IF( J.LT.N ) THEN + CALL ZAXPY( N-J, RHS( 2 ), B( J, J+1 ), LDB, + $ C( I, J+1 ), LDC ) + CALL ZAXPY( N-J, RHS( 2 ), E( J, J+1 ), LDE, + $ F( I, J+1 ), LDF ) + END IF +* + 20 CONTINUE + 30 CONTINUE + 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 = ONE + SCALOC = ONE + DO 80 I = 1, M + DO 70 J = N, 1, -1 +* +* Build 2 by 2 system Z' +* + Z( 1, 1 ) = DCONJG( A( I, I ) ) + Z( 2, 1 ) = -DCONJG( B( J, J ) ) + Z( 1, 2 ) = DCONJG( D( I, I ) ) + Z( 2, 2 ) = -DCONJG( E( J, J ) ) +* +* +* Set up right hand side(s) +* + RHS( 1 ) = C( I, J ) + RHS( 2 ) = F( I, J ) +* +* Solve Z' * x = RHS +* + CALL ZGETC2( LDZ, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR + CALL ZGESC2( LDZ, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 40 K = 1, N + CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), C( 1, K ), + $ 1 ) + CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), F( 1, K ), + $ 1 ) + 40 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Unpack solution vector(s) +* + C( I, J ) = RHS( 1 ) + F( I, J ) = RHS( 2 ) +* +* Substitute R(I, J) and L(I, J) into remaining equation. +* + DO 50 K = 1, J - 1 + F( I, K ) = F( I, K ) + RHS( 1 )*DCONJG( B( K, J ) ) + + $ RHS( 2 )*DCONJG( E( K, J ) ) + 50 CONTINUE + DO 60 K = I + 1, M + C( K, J ) = C( K, J ) - DCONJG( A( I, K ) )*RHS( 1 ) - + $ DCONJG( D( I, K ) )*RHS( 2 ) + 60 CONTINUE +* + 70 CONTINUE + 80 CONTINUE + END IF + RETURN +* +* End of ZTGSY2 +* + END diff --git a/2.3-1/src/fortran/lapack/ztgsyl.f b/2.3-1/src/fortran/lapack/ztgsyl.f new file mode 100644 index 00000000..af808a31 --- /dev/null +++ b/2.3-1/src/fortran/lapack/ztgsyl.f @@ -0,0 +1,575 @@ + SUBROUTINE ZTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, + $ LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, + $ IWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, + $ LWORK, M, N + DOUBLE PRECISION DIF, SCALE +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), E( LDE, * ), F( LDF, * ), + $ WORK( * ) +* .. +* +* 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) +* If IJOB = 0, IWORK is not referenced. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = (0.0D+0, 0.0D+0) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, NOTRAN + INTEGER I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K, + $ LINFO, LWMIN, MB, NB, P, PQ, Q + DOUBLE PRECISION DSCALE, DSUM, SCALE2, SCALOC +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGEMM, ZLACPY, ZLASET, ZSCAL, ZTGSY2 +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode and test input parameters +* + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( NOTRAN ) THEN + IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.4 ) ) THEN + INFO = -2 + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( M.LE.0 ) THEN + INFO = -3 + ELSE IF( N.LE.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, M ) ) THEN + INFO = -12 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -16 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + IF( NOTRAN ) THEN + IF( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN + LWMIN = MAX( 1, 2*M*N ) + ELSE + LWMIN = 1 + END IF + ELSE + LWMIN = 1 + END IF + WORK( 1 ) = LWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -20 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTGSYL', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + SCALE = 1 + IF( NOTRAN ) THEN + IF( IJOB.NE.0 ) THEN + DIF = 0 + END IF + END IF + RETURN + END IF +* +* Determine optimal block sizes MB and NB +* + MB = ILAENV( 2, 'ZTGSYL', TRANS, M, N, -1, -1 ) + NB = ILAENV( 5, 'ZTGSYL', TRANS, M, N, -1, -1 ) +* + ISOLVE = 1 + IFUNC = 0 + IF( NOTRAN ) THEN + IF( IJOB.GE.3 ) THEN + IFUNC = IJOB - 2 + CALL ZLASET( 'F', M, N, CZERO, CZERO, C, LDC ) + CALL ZLASET( 'F', M, N, CZERO, CZERO, F, LDF ) + ELSE IF( IJOB.GE.1 .AND. NOTRAN ) THEN + ISOLVE = 2 + END IF + END IF +* + IF( ( MB.LE.1 .AND. NB.LE.1 ) .OR. ( MB.GE.M .AND. NB.GE.N ) ) + $ THEN +* +* Use unblocked Level 2 solver +* + DO 30 IROUND = 1, ISOLVE +* + SCALE = ONE + DSCALE = ZERO + DSUM = ONE + PQ = M*N + CALL ZTGSY2( TRANS, IFUNC, M, N, A, LDA, B, LDB, C, LDC, D, + $ LDD, E, LDE, F, LDF, SCALE, DSUM, DSCALE, + $ INFO ) + IF( DSCALE.NE.ZERO ) THEN + IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN + DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) ) + ELSE + DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) ) + END IF + END IF + IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN + IF( NOTRAN ) THEN + IFUNC = IJOB + END IF + SCALE2 = SCALE + CALL ZLACPY( 'F', M, N, C, LDC, WORK, M ) + CALL ZLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M ) + CALL ZLASET( 'F', M, N, CZERO, CZERO, C, LDC ) + CALL ZLASET( 'F', M, N, CZERO, CZERO, F, LDF ) + ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN + CALL ZLACPY( 'F', M, N, WORK, M, C, LDC ) + CALL ZLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF ) + SCALE = SCALE2 + END IF + 30 CONTINUE +* + RETURN +* + END IF +* +* Determine block structure of A +* + P = 0 + I = 1 + 40 CONTINUE + IF( I.GT.M ) + $ GO TO 50 + P = P + 1 + IWORK( P ) = I + I = I + MB + IF( I.GE.M ) + $ GO TO 50 + GO TO 40 + 50 CONTINUE + IWORK( P+1 ) = M + 1 + IF( IWORK( P ).EQ.IWORK( P+1 ) ) + $ P = P - 1 +* +* Determine block structure of B +* + Q = P + 1 + J = 1 + 60 CONTINUE + IF( J.GT.N ) + $ GO TO 70 +* + Q = Q + 1 + IWORK( Q ) = J + J = J + NB + IF( J.GE.N ) + $ GO TO 70 + GO TO 60 +* + 70 CONTINUE + IWORK( Q+1 ) = N + 1 + IF( IWORK( Q ).EQ.IWORK( Q+1 ) ) + $ Q = Q - 1 +* + IF( NOTRAN ) THEN + DO 150 IROUND = 1, ISOLVE +* +* 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 = ONE + DSCALE = ZERO + DSUM = ONE + DO 130 J = P + 2, Q + JS = IWORK( J ) + JE = IWORK( J+1 ) - 1 + NB = JE - JS + 1 + DO 120 I = P, 1, -1 + IS = IWORK( I ) + IE = IWORK( I+1 ) - 1 + MB = IE - IS + 1 + CALL ZTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA, + $ B( JS, JS ), LDB, C( IS, JS ), LDC, + $ D( IS, IS ), LDD, E( JS, JS ), LDE, + $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE, + $ LINFO ) + IF( LINFO.GT.0 ) + $ INFO = LINFO + PQ = PQ + MB*NB + IF( SCALOC.NE.ONE ) THEN + DO 80 K = 1, JS - 1 + CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), + $ C( 1, K ), 1 ) + CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), + $ F( 1, K ), 1 ) + 80 CONTINUE + DO 90 K = JS, JE + CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ), + $ C( 1, K ), 1 ) + CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ), + $ F( 1, K ), 1 ) + 90 CONTINUE + DO 100 K = JS, JE + CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ), + $ C( IE+1, K ), 1 ) + CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ), + $ F( IE+1, K ), 1 ) + 100 CONTINUE + DO 110 K = JE + 1, N + CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), + $ C( 1, K ), 1 ) + CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), + $ F( 1, K ), 1 ) + 110 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Substitute R(I,J) and L(I,J) into remaining equation. +* + IF( I.GT.1 ) THEN + CALL ZGEMM( 'N', 'N', IS-1, NB, MB, + $ DCMPLX( -ONE, ZERO ), A( 1, IS ), LDA, + $ C( IS, JS ), LDC, DCMPLX( ONE, ZERO ), + $ C( 1, JS ), LDC ) + CALL ZGEMM( 'N', 'N', IS-1, NB, MB, + $ DCMPLX( -ONE, ZERO ), D( 1, IS ), LDD, + $ C( IS, JS ), LDC, DCMPLX( ONE, ZERO ), + $ F( 1, JS ), LDF ) + END IF + IF( J.LT.Q ) THEN + CALL ZGEMM( 'N', 'N', MB, N-JE, NB, + $ DCMPLX( ONE, ZERO ), F( IS, JS ), LDF, + $ B( JS, JE+1 ), LDB, + $ DCMPLX( ONE, ZERO ), C( IS, JE+1 ), + $ LDC ) + CALL ZGEMM( 'N', 'N', MB, N-JE, NB, + $ DCMPLX( ONE, ZERO ), F( IS, JS ), LDF, + $ E( JS, JE+1 ), LDE, + $ DCMPLX( ONE, ZERO ), F( IS, JE+1 ), + $ LDF ) + END IF + 120 CONTINUE + 130 CONTINUE + IF( DSCALE.NE.ZERO ) THEN + IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN + DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) ) + ELSE + DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) ) + END IF + END IF + IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN + IF( NOTRAN ) THEN + IFUNC = IJOB + END IF + SCALE2 = SCALE + CALL ZLACPY( 'F', M, N, C, LDC, WORK, M ) + CALL ZLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M ) + CALL ZLASET( 'F', M, N, CZERO, CZERO, C, LDC ) + CALL ZLASET( 'F', M, N, CZERO, CZERO, F, LDF ) + ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN + CALL ZLACPY( 'F', M, N, WORK, M, C, LDC ) + CALL ZLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF ) + SCALE = SCALE2 + END IF + 150 CONTINUE + 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 = ONE + DO 210 I = 1, P + IS = IWORK( I ) + IE = IWORK( I+1 ) - 1 + MB = IE - IS + 1 + DO 200 J = Q, P + 2, -1 + JS = IWORK( J ) + JE = IWORK( J+1 ) - 1 + NB = JE - JS + 1 + CALL ZTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA, + $ B( JS, JS ), LDB, C( IS, JS ), LDC, + $ D( IS, IS ), LDD, E( JS, JS ), LDE, + $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE, + $ LINFO ) + IF( LINFO.GT.0 ) + $ INFO = LINFO + IF( SCALOC.NE.ONE ) THEN + DO 160 K = 1, JS - 1 + CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), C( 1, K ), + $ 1 ) + CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), F( 1, K ), + $ 1 ) + 160 CONTINUE + DO 170 K = JS, JE + CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ), + $ C( 1, K ), 1 ) + CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ), + $ F( 1, K ), 1 ) + 170 CONTINUE + DO 180 K = JS, JE + CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ), + $ C( IE+1, K ), 1 ) + CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ), + $ F( IE+1, K ), 1 ) + 180 CONTINUE + DO 190 K = JE + 1, N + CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), C( 1, K ), + $ 1 ) + CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), F( 1, K ), + $ 1 ) + 190 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Substitute R(I,J) and L(I,J) into remaining equation. +* + IF( J.GT.P+2 ) THEN + CALL ZGEMM( 'N', 'C', MB, JS-1, NB, + $ DCMPLX( ONE, ZERO ), C( IS, JS ), LDC, + $ B( 1, JS ), LDB, DCMPLX( ONE, ZERO ), + $ F( IS, 1 ), LDF ) + CALL ZGEMM( 'N', 'C', MB, JS-1, NB, + $ DCMPLX( ONE, ZERO ), F( IS, JS ), LDF, + $ E( 1, JS ), LDE, DCMPLX( ONE, ZERO ), + $ F( IS, 1 ), LDF ) + END IF + IF( I.LT.P ) THEN + CALL ZGEMM( 'C', 'N', M-IE, NB, MB, + $ DCMPLX( -ONE, ZERO ), A( IS, IE+1 ), LDA, + $ C( IS, JS ), LDC, DCMPLX( ONE, ZERO ), + $ C( IE+1, JS ), LDC ) + CALL ZGEMM( 'C', 'N', M-IE, NB, MB, + $ DCMPLX( -ONE, ZERO ), D( IS, IE+1 ), LDD, + $ F( IS, JS ), LDF, DCMPLX( ONE, ZERO ), + $ C( IE+1, JS ), LDC ) + END IF + 200 CONTINUE + 210 CONTINUE + END IF +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of ZTGSYL +* + END diff --git a/2.3-1/src/fortran/lapack/ztrevc.f b/2.3-1/src/fortran/lapack/ztrevc.f new file mode 100644 index 00000000..21142f42 --- /dev/null +++ b/2.3-1/src/fortran/lapack/ztrevc.f @@ -0,0 +1,386 @@ + SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + $ LDVR, MM, M, WORK, RWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER HOWMNY, SIDE + INTEGER INFO, LDT, LDVL, LDVR, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CMZERO, CMONE + PARAMETER ( CMZERO = ( 0.0D+0, 0.0D+0 ), + $ CMONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV + INTEGER I, II, IS, J, K, KI + DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL + COMPLEX*16 CDUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH, DZASUM + EXTERNAL LSAME, IZAMAX, DLAMCH, DZASUM +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + BOTHV = LSAME( SIDE, 'B' ) + RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV + LEFTV = LSAME( SIDE, 'L' ) .OR. 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 ) THEN + M = 0 + DO 10 J = 1, N + IF( SELECT( J ) ) + $ M = M + 1 + 10 CONTINUE + ELSE + M = N + END IF +* + INFO = 0 + IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -1 + ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN + INFO = -10 + ELSE IF( MM.LT.M ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTREVC', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* +* Set the constants to control overflow. +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( N / ULP ) +* +* Store the diagonal elements of T in working array WORK. +* + DO 20 I = 1, N + WORK( I+N ) = T( I, I ) + 20 CONTINUE +* +* Compute 1-norm of each column of strictly upper triangular +* part of T to control overflow in triangular solver. +* + RWORK( 1 ) = ZERO + DO 30 J = 2, N + RWORK( J ) = DZASUM( J-1, T( 1, J ), 1 ) + 30 CONTINUE +* + IF( RIGHTV ) THEN +* +* Compute right eigenvectors. +* + IS = M + DO 80 KI = N, 1, -1 +* + IF( SOMEV ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 80 + END IF + SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) +* + WORK( 1 ) = CMONE +* +* Form right-hand side. +* + DO 40 K = 1, KI - 1 + WORK( K ) = -T( K, KI ) + 40 CONTINUE +* +* Solve the triangular system: +* (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. +* + DO 50 K = 1, KI - 1 + T( K, K ) = T( K, K ) - T( KI, KI ) + IF( CABS1( T( K, K ) ).LT.SMIN ) + $ T( K, K ) = SMIN + 50 CONTINUE +* + IF( KI.GT.1 ) THEN + CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', 'Y', + $ KI-1, T, LDT, WORK( 1 ), SCALE, RWORK, + $ INFO ) + WORK( KI ) = SCALE + END IF +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN + CALL ZCOPY( KI, WORK( 1 ), 1, VR( 1, IS ), 1 ) +* + II = IZAMAX( KI, VR( 1, IS ), 1 ) + REMAX = ONE / CABS1( VR( II, IS ) ) + CALL ZDSCAL( KI, REMAX, VR( 1, IS ), 1 ) +* + DO 60 K = KI + 1, N + VR( K, IS ) = CMZERO + 60 CONTINUE + ELSE + IF( KI.GT.1 ) + $ CALL ZGEMV( 'N', N, KI-1, CMONE, VR, LDVR, WORK( 1 ), + $ 1, DCMPLX( SCALE ), VR( 1, KI ), 1 ) +* + II = IZAMAX( N, VR( 1, KI ), 1 ) + REMAX = ONE / CABS1( VR( II, KI ) ) + CALL ZDSCAL( N, REMAX, VR( 1, KI ), 1 ) + END IF +* +* Set back the original diagonal elements of T. +* + DO 70 K = 1, KI - 1 + T( K, K ) = WORK( K+N ) + 70 CONTINUE +* + IS = IS - 1 + 80 CONTINUE + END IF +* + IF( LEFTV ) THEN +* +* Compute left eigenvectors. +* + IS = 1 + DO 130 KI = 1, N +* + IF( SOMEV ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 130 + END IF + SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) +* + WORK( N ) = CMONE +* +* Form right-hand side. +* + DO 90 K = KI + 1, N + WORK( K ) = -DCONJG( T( KI, K ) ) + 90 CONTINUE +* +* Solve the triangular system: +* (T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. +* + DO 100 K = KI + 1, N + T( K, K ) = T( K, K ) - T( KI, KI ) + IF( CABS1( T( K, K ) ).LT.SMIN ) + $ T( K, K ) = SMIN + 100 CONTINUE +* + IF( KI.LT.N ) THEN + CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit', + $ 'Y', N-KI, T( KI+1, KI+1 ), LDT, + $ WORK( KI+1 ), SCALE, RWORK, INFO ) + WORK( KI ) = SCALE + END IF +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.OVER ) THEN + CALL ZCOPY( N-KI+1, WORK( KI ), 1, VL( KI, IS ), 1 ) +* + II = IZAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 + REMAX = ONE / CABS1( VL( II, IS ) ) + CALL ZDSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) +* + DO 110 K = 1, KI - 1 + VL( K, IS ) = CMZERO + 110 CONTINUE + ELSE + IF( KI.LT.N ) + $ CALL ZGEMV( 'N', N, N-KI, CMONE, VL( 1, KI+1 ), LDVL, + $ WORK( KI+1 ), 1, DCMPLX( SCALE ), + $ VL( 1, KI ), 1 ) +* + II = IZAMAX( N, VL( 1, KI ), 1 ) + REMAX = ONE / CABS1( VL( II, KI ) ) + CALL ZDSCAL( N, REMAX, VL( 1, KI ), 1 ) + END IF +* +* Set back the original diagonal elements of T. +* + DO 120 K = KI + 1, N + T( K, K ) = WORK( K+N ) + 120 CONTINUE +* + IS = IS + 1 + 130 CONTINUE + END IF +* + RETURN +* +* End of ZTREVC +* + END diff --git a/2.3-1/src/fortran/lapack/ztrexc.f b/2.3-1/src/fortran/lapack/ztrexc.f new file mode 100644 index 00000000..69313696 --- /dev/null +++ b/2.3-1/src/fortran/lapack/ztrexc.f @@ -0,0 +1,162 @@ + SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER COMPQ + INTEGER IFST, ILST, INFO, LDQ, LDT, N +* .. +* .. Array Arguments .. + COMPLEX*16 Q( LDQ, * ), T( LDT, * ) +* .. +* +* 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 .. + LOGICAL WANTQ + INTEGER K, M1, M2, M3 + DOUBLE PRECISION CS + COMPLEX*16 SN, T11, T22, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARTG, ZROT +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters. +* + INFO = 0 + WANTQ = LSAME( COMPQ, 'V' ) + IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN + INFO = -6 + ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN + INFO = -7 + ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTREXC', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.1 .OR. IFST.EQ.ILST ) + $ RETURN +* + IF( IFST.LT.ILST ) THEN +* +* 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 + END IF +* + DO 10 K = IFST + M1, ILST + M2, M3 +* +* Interchange the k-th and (k+1)-th diagonal elements. +* + T11 = T( K, K ) + T22 = T( K+1, K+1 ) +* +* Determine the transformation to perform the interchange. +* + CALL ZLARTG( T( K, K+1 ), T22-T11, CS, SN, TEMP ) +* +* Apply transformation to the matrix T. +* + IF( K+2.LE.N ) + $ CALL ZROT( N-K-1, T( K, K+2 ), LDT, T( K+1, K+2 ), LDT, CS, + $ SN ) + CALL ZROT( K-1, T( 1, K ), 1, T( 1, K+1 ), 1, CS, + $ DCONJG( SN ) ) +* + T( K, K ) = T22 + T( K+1, K+1 ) = T11 +* + IF( WANTQ ) THEN +* +* Accumulate transformation in the matrix Q. +* + CALL ZROT( N, Q( 1, K ), 1, Q( 1, K+1 ), 1, CS, + $ DCONJG( SN ) ) + END IF +* + 10 CONTINUE +* + RETURN +* +* End of ZTREXC +* + END diff --git a/2.3-1/src/fortran/lapack/ztrsen.f b/2.3-1/src/fortran/lapack/ztrsen.f new file mode 100644 index 00000000..a07a22f6 --- /dev/null +++ b/2.3-1/src/fortran/lapack/ztrsen.f @@ -0,0 +1,359 @@ + SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, + $ SEP, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* 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 .. + CHARACTER COMPQ, JOB + INTEGER INFO, LDQ, LDT, LWORK, M, N + DOUBLE PRECISION S, SEP +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + COMPLEX*16 Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * ) +* .. +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, WANTBH, WANTQ, WANTS, WANTSP + INTEGER IERR, K, KASE, KS, LWMIN, N1, N2, NN + DOUBLE PRECISION EST, RNORM, SCALE +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) + DOUBLE PRECISION RWORK( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION ZLANGE + EXTERNAL LSAME, ZLANGE +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLACN2, ZLACPY, ZTREXC, ZTRSYL +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters. +* + WANTBH = LSAME( JOB, 'B' ) + WANTS = LSAME( JOB, 'E' ) .OR. WANTBH + WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH + WANTQ = LSAME( COMPQ, 'V' ) +* +* Set M to the number of selected eigenvalues. +* + M = 0 + DO 10 K = 1, N + IF( SELECT( K ) ) + $ M = M + 1 + 10 CONTINUE +* + N1 = M + N2 = N - M + NN = N1*N2 +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) +* + IF( WANTSP ) THEN + LWMIN = MAX( 1, 2*NN ) + ELSE IF( LSAME( JOB, 'N' ) ) THEN + LWMIN = 1 + ELSE IF( LSAME( JOB, 'E' ) ) THEN + LWMIN = MAX( 1, NN ) + END IF +* + IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP ) + $ THEN + INFO = -1 + ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LWMIN + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTRSEN', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.N .OR. M.EQ.0 ) THEN + IF( WANTS ) + $ S = ONE + IF( WANTSP ) + $ SEP = ZLANGE( '1', N, N, T, LDT, RWORK ) + GO TO 40 + END IF +* +* Collect the selected eigenvalues at the top left corner of T. +* + KS = 0 + DO 20 K = 1, N + IF( SELECT( K ) ) THEN + KS = KS + 1 +* +* Swap the K-th eigenvalue to position KS. +* + IF( K.NE.KS ) + $ CALL ZTREXC( COMPQ, N, T, LDT, Q, LDQ, K, KS, IERR ) + END IF + 20 CONTINUE +* + IF( WANTS ) THEN +* +* Solve the Sylvester equation for R: +* +* T11*R - R*T22 = scale*T12 +* + CALL ZLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 ) + CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ), + $ LDT, WORK, N1, SCALE, IERR ) +* +* Estimate the reciprocal of the condition number of the cluster +* of eigenvalues. +* + RNORM = ZLANGE( 'F', N1, N2, WORK, N1, RWORK ) + IF( RNORM.EQ.ZERO ) THEN + S = ONE + ELSE + S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )* + $ SQRT( RNORM ) ) + END IF + END IF +* + IF( WANTSP ) THEN +* +* Estimate sep(T11,T22). +* + EST = ZERO + KASE = 0 + 30 CONTINUE + CALL ZLACN2( NN, WORK( NN+1 ), WORK, EST, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN +* +* Solve T11*R - R*T22 = scale*X. +* + CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT, + $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, + $ IERR ) + ELSE +* +* Solve T11'*R - R*T22' = scale*X. +* + CALL ZTRSYL( 'C', 'C', -1, N1, N2, T, LDT, + $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, + $ IERR ) + END IF + GO TO 30 + END IF +* + SEP = SCALE / EST + END IF +* + 40 CONTINUE +* +* Copy reordered eigenvalues to W. +* + DO 50 K = 1, N + W( K ) = T( K, K ) + 50 CONTINUE +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of ZTRSEN +* + END diff --git a/2.3-1/src/fortran/lapack/ztrsyl.f b/2.3-1/src/fortran/lapack/ztrsyl.f new file mode 100644 index 00000000..d2e0ecc7 --- /dev/null +++ b/2.3-1/src/fortran/lapack/ztrsyl.f @@ -0,0 +1,365 @@ + SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, + $ LDC, SCALE, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER TRANA, TRANB + INTEGER INFO, ISGN, LDA, LDB, LDC, M, N + DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* 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 .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRNA, NOTRNB + INTEGER J, K, L + DOUBLE PRECISION BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN, + $ SMLNUM + COMPLEX*16 A11, SUML, SUMR, VEC, X11 +* .. +* .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLANGE + COMPLEX*16 ZDOTC, ZDOTU, ZLADIV + EXTERNAL LSAME, DLAMCH, ZLANGE, ZDOTC, ZDOTU, ZLADIV +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, XERBLA, ZDSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOTRNA = LSAME( TRANA, 'N' ) + NOTRNB = LSAME( TRANB, 'N' ) +* + INFO = 0 + IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'C' ) ) THEN + INFO = -2 + ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTRSYL', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Set constants to control overflow +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM*DBLE( M*N ) / EPS + BIGNUM = ONE / SMLNUM + SMIN = MAX( SMLNUM, EPS*ZLANGE( 'M', M, M, A, LDA, DUM ), + $ EPS*ZLANGE( 'M', N, N, B, LDB, DUM ) ) + SCALE = ONE + SGN = ISGN +* + IF( NOTRNA .AND. NOTRNB ) THEN +* +* 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 +* + DO 30 L = 1, N + DO 20 K = M, 1, -1 +* + SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA, + $ C( MIN( K+1, M ), L ), 1 ) + SUMR = ZDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 ) + VEC = C( K, L ) - ( SUML+SGN*SUMR ) +* + SCALOC = ONE + A11 = A( K, K ) + SGN*B( L, L ) + DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 ) +* + IF( SCALOC.NE.ONE ) THEN + DO 10 J = 1, N + CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 ) + 10 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K, L ) = X11 +* + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN +* +* 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 +* + DO 60 L = 1, N + DO 50 K = 1, M +* + SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 ) + SUMR = ZDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 ) + VEC = C( K, L ) - ( SUML+SGN*SUMR ) +* + SCALOC = ONE + A11 = DCONJG( A( K, K ) ) + SGN*B( L, L ) + DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF +* + X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 ) +* + IF( SCALOC.NE.ONE ) THEN + DO 40 J = 1, N + CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 ) + 40 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K, L ) = X11 +* + 50 CONTINUE + 60 CONTINUE +* + ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN +* +* 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 +* + DO 90 L = N, 1, -1 + DO 80 K = 1, M +* + SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 ) + SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC, + $ B( L, MIN( L+1, N ) ), LDB ) + VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) ) +* + SCALOC = ONE + A11 = DCONJG( A( K, K )+SGN*B( L, L ) ) + DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF +* + X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 ) +* + IF( SCALOC.NE.ONE ) THEN + DO 70 J = 1, N + CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 ) + 70 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K, L ) = X11 +* + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN +* +* 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 +* + DO 120 L = N, 1, -1 + DO 110 K = M, 1, -1 +* + SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA, + $ C( MIN( K+1, M ), L ), 1 ) + SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC, + $ B( L, MIN( L+1, N ) ), LDB ) + VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) ) +* + SCALOC = ONE + A11 = A( K, K ) + SGN*DCONJG( B( L, L ) ) + DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF +* + X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 ) +* + IF( SCALOC.NE.ONE ) THEN + DO 100 J = 1, N + CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 ) + 100 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K, L ) = X11 +* + 110 CONTINUE + 120 CONTINUE +* + END IF +* + RETURN +* +* End of ZTRSYL +* + END diff --git a/2.3-1/src/fortran/lapack/ztrti2.f b/2.3-1/src/fortran/lapack/ztrti2.f new file mode 100644 index 00000000..73c7bbc3 --- /dev/null +++ b/2.3-1/src/fortran/lapack/ztrti2.f @@ -0,0 +1,146 @@ + SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIAG, UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* 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 .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT, UPPER + INTEGER J + COMPLEX*16 AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZSCAL, ZTRMV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + NOUNIT = LSAME( DIAG, 'N' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTRTI2', -INFO ) + RETURN + END IF +* + IF( UPPER ) THEN +* +* Compute inverse of upper triangular matrix. +* + DO 10 J = 1, N + IF( NOUNIT ) THEN + A( J, J ) = ONE / A( J, J ) + AJJ = -A( J, J ) + ELSE + AJJ = -ONE + END IF +* +* Compute elements 1:j-1 of j-th column. +* + CALL ZTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, + $ A( 1, J ), 1 ) + CALL ZSCAL( J-1, AJJ, A( 1, J ), 1 ) + 10 CONTINUE + ELSE +* +* Compute inverse of lower triangular matrix. +* + DO 20 J = N, 1, -1 + IF( NOUNIT ) THEN + A( J, J ) = ONE / A( J, J ) + AJJ = -A( J, J ) + ELSE + AJJ = -ONE + END IF + IF( J.LT.N ) THEN +* +* Compute elements j+1:n of j-th column. +* + CALL ZTRMV( 'Lower', 'No transpose', DIAG, N-J, + $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) + CALL ZSCAL( N-J, AJJ, A( J+1, J ), 1 ) + END IF + 20 CONTINUE + END IF +* + RETURN +* +* End of ZTRTI2 +* + END diff --git a/2.3-1/src/fortran/lapack/ztrtri.f b/2.3-1/src/fortran/lapack/ztrtri.f new file mode 100644 index 00000000..7caa9771 --- /dev/null +++ b/2.3-1/src/fortran/lapack/ztrtri.f @@ -0,0 +1,177 @@ + SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIAG, UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* 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 .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT, UPPER + INTEGER J, JB, NB, NN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZTRMM, ZTRSM, ZTRTI2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + NOUNIT = LSAME( DIAG, 'N' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTRTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Check for singularity if non-unit. +* + IF( NOUNIT ) THEN + DO 10 INFO = 1, N + IF( A( INFO, INFO ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + INFO = 0 + END IF +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'ZTRTRI', UPLO // DIAG, N, -1, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) + ELSE +* +* Use blocked code +* + IF( UPPER ) THEN +* +* Compute inverse of upper triangular matrix +* + DO 20 J = 1, N, NB + JB = MIN( NB, N-J+1 ) +* +* Compute rows 1:j-1 of current block column +* + CALL ZTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, + $ JB, ONE, A, LDA, A( 1, J ), LDA ) + CALL ZTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, + $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) +* +* Compute inverse of current diagonal block +* + CALL ZTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) + 20 CONTINUE + ELSE +* +* Compute inverse of lower triangular matrix +* + NN = ( ( N-1 ) / NB )*NB + 1 + DO 30 J = NN, 1, -NB + JB = MIN( NB, N-J+1 ) + IF( J+JB.LE.N ) THEN +* +* Compute rows j+jb:n of current block column +* + CALL ZTRMM( 'Left', 'Lower', 'No transpose', DIAG, + $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, + $ A( J+JB, J ), LDA ) + CALL ZTRSM( 'Right', 'Lower', 'No transpose', DIAG, + $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, + $ A( J+JB, J ), LDA ) + END IF +* +* Compute inverse of current diagonal block +* + CALL ZTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) + 30 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZTRTRI +* + END diff --git a/2.3-1/src/fortran/lapack/ztzrzf.f b/2.3-1/src/fortran/lapack/ztzrzf.f new file mode 100644 index 00000000..5c9c6543 --- /dev/null +++ b/2.3-1/src/fortran/lapack/ztzrzf.f @@ -0,0 +1,244 @@ + SUBROUTINE ZTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IWS, KI, KK, LDWORK, LWKOPT, M1, MU, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARZB, ZLARZT, ZLATRZ +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.M ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( M.EQ.0 .OR. M.EQ.N ) THEN + LWKOPT = 1 + ELSE +* +* Determine the block size. +* + NB = ILAENV( 1, 'ZGERQF', ' ', M, N, -1, -1 ) + LWKOPT = M*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTZRZF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 ) THEN + RETURN + ELSE IF( M.EQ.N ) THEN + DO 10 I = 1, N + TAU( I ) = ZERO + 10 CONTINUE + RETURN + END IF +* + NBMIN = 2 + NX = 1 + IWS = M + IF( NB.GT.1 .AND. NB.LT.M ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'ZGERQF', ' ', M, N, -1, -1 ) ) + IF( NX.LT.M ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = M + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'ZGERQF', ' ', M, N, -1, + $ -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.M .AND. NX.LT.M ) THEN +* +* Use blocked code initially. +* The last kk rows are handled by the block method. +* + M1 = MIN( M+1, N ) + KI = ( ( M-NX-1 ) / NB )*NB + KK = MIN( M, KI+NB ) +* + DO 20 I = M - KK + KI + 1, M - KK + 1, -NB + IB = MIN( M-I+1, NB ) +* +* Compute the TZ factorization of the current block +* A(i:i+ib-1,i:n) +* + CALL ZLATRZ( IB, N-I+1, N-M, A( I, I ), LDA, TAU( I ), + $ WORK ) + IF( I.GT.1 ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i+ib-1) . . . H(i+1) H(i) +* + CALL ZLARZT( 'Backward', 'Rowwise', N-M, IB, A( I, M1 ), + $ LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(1:i-1,i:n) from the right +* + CALL ZLARZB( 'Right', 'No transpose', 'Backward', + $ 'Rowwise', I-1, N-I+1, IB, N-M, A( I, M1 ), + $ LDA, WORK, LDWORK, A( 1, I ), LDA, + $ WORK( IB+1 ), LDWORK ) + END IF + 20 CONTINUE + MU = I + NB - 1 + ELSE + MU = M + END IF +* +* Use unblocked code to factor the last or only block +* + IF( MU.GT.0 ) + $ CALL ZLATRZ( MU, N, N-M, A, LDA, TAU, WORK ) +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of ZTZRZF +* + END diff --git a/2.3-1/src/fortran/lapack/zung2l.f b/2.3-1/src/fortran/lapack/zung2l.f new file mode 100644 index 00000000..29178b90 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zung2l.f @@ -0,0 +1,128 @@ + SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, II, J, L +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF, ZSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNG2L', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Initialise columns 1:n-k to columns of the unit matrix +* + DO 20 J = 1, N - K + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( M-N+J, J ) = ONE + 20 CONTINUE +* + DO 40 I = 1, K + II = N - K + I +* +* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left +* + A( M-N+II, II ) = ONE + CALL ZLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, + $ LDA, WORK ) + CALL ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) + A( M-N+II, II ) = ONE - TAU( I ) +* +* Set A(m-k+i+1:m,n-k+i) to zero +* + DO 30 L = M - N + II + 1, M + A( L, II ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of ZUNG2L +* + END diff --git a/2.3-1/src/fortran/lapack/zung2r.f b/2.3-1/src/fortran/lapack/zung2r.f new file mode 100644 index 00000000..cd89f26e --- /dev/null +++ b/2.3-1/src/fortran/lapack/zung2r.f @@ -0,0 +1,130 @@ + SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF, ZSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNG2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Initialise columns k+1:n to columns of the unit matrix +* + DO 20 J = K + 1, N + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( J, J ) = ONE + 20 CONTINUE +* + DO 40 I = K, 1, -1 +* +* Apply H(i) to A(i:m,i:n) from the left +* + IF( I.LT.N ) THEN + A( I, I ) = ONE + CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + END IF + IF( I.LT.M ) + $ CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = ONE - TAU( I ) +* +* Set A(1:i-1,i) to zero +* + DO 30 L = 1, I - 1 + A( L, I ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of ZUNG2R +* + END diff --git a/2.3-1/src/fortran/lapack/zungbr.f b/2.3-1/src/fortran/lapack/zungbr.f new file mode 100644 index 00000000..94f74820 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zungbr.f @@ -0,0 +1,245 @@ + SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER VECT + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, WANTQ + INTEGER I, IINFO, J, LWKOPT, MN, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZUNGLQ, ZUNGQR +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + WANTQ = LSAME( VECT, 'Q' ) + MN = MIN( M, N ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M, + $ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT. + $ MIN( N, K ) ) ) ) THEN + INFO = -3 + ELSE IF( K.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( WANTQ ) THEN + NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) + ELSE + NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 ) + END IF + LWKOPT = MAX( 1, MN )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNGBR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( WANTQ ) THEN +* +* Form Q, determined by a call to ZGEBRD to reduce an m-by-k +* matrix +* + IF( M.GE.K ) THEN +* +* If m >= k, assume m >= n >= k +* + CALL ZUNGQR( M, N, K, A, LDA, TAU, WORK, 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 +* + DO 20 J = M, 2, -1 + A( 1, J ) = ZERO + DO 10 I = J + 1, M + A( I, J ) = A( I, J-1 ) + 10 CONTINUE + 20 CONTINUE + A( 1, 1 ) = ONE + DO 30 I = 2, M + A( I, 1 ) = ZERO + 30 CONTINUE + IF( M.GT.1 ) THEN +* +* Form Q(2:m,2:m) +* + CALL ZUNGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, + $ LWORK, IINFO ) + END IF + END IF + ELSE +* +* Form P', determined by a call to ZGEBRD to reduce a k-by-n +* matrix +* + IF( K.LT.N ) THEN +* +* If k < n, assume k <= m <= n +* + CALL ZUNGLQ( M, N, K, A, LDA, TAU, WORK, 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( 1, 1 ) = ONE + DO 40 I = 2, N + A( I, 1 ) = ZERO + 40 CONTINUE + DO 60 J = 2, N + DO 50 I = J - 1, 2, -1 + A( I, J ) = A( I-1, J ) + 50 CONTINUE + A( 1, J ) = ZERO + 60 CONTINUE + IF( N.GT.1 ) THEN +* +* Form P'(2:n,2:n) +* + CALL ZUNGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, + $ LWORK, IINFO ) + END IF + END IF + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZUNGBR +* + END diff --git a/2.3-1/src/fortran/lapack/zunghr.f b/2.3-1/src/fortran/lapack/zunghr.f new file mode 100644 index 00000000..fcf32abf --- /dev/null +++ b/2.3-1/src/fortran/lapack/zunghr.f @@ -0,0 +1,165 @@ + SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IINFO, J, LWKOPT, NB, NH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZUNGQR +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NH = IHI - ILO + LQUERY = ( LWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'ZUNGQR', ' ', NH, NH, NH, -1 ) + LWKOPT = MAX( 1, NH )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNGHR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* 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 +* + DO 40 J = IHI, ILO + 1, -1 + DO 10 I = 1, J - 1 + A( I, J ) = ZERO + 10 CONTINUE + DO 20 I = J + 1, IHI + A( I, J ) = A( I, J-1 ) + 20 CONTINUE + DO 30 I = IHI + 1, N + A( I, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + DO 60 J = 1, ILO + DO 50 I = 1, N + A( I, J ) = ZERO + 50 CONTINUE + A( J, J ) = ONE + 60 CONTINUE + DO 80 J = IHI + 1, N + DO 70 I = 1, N + A( I, J ) = ZERO + 70 CONTINUE + A( J, J ) = ONE + 80 CONTINUE +* + IF( NH.GT.0 ) THEN +* +* Generate Q(ilo+1:ihi,ilo+1:ihi) +* + CALL ZUNGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), + $ WORK, LWORK, IINFO ) + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZUNGHR +* + END diff --git a/2.3-1/src/fortran/lapack/zungl2.f b/2.3-1/src/fortran/lapack/zungl2.f new file mode 100644 index 00000000..502411b4 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zungl2.f @@ -0,0 +1,136 @@ + SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLACGV, ZLARF, ZSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.M ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNGL2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.LE.0 ) + $ RETURN +* + IF( K.LT.M ) THEN +* +* Initialise rows k+1:m to rows of the unit matrix +* + DO 20 J = 1, N + DO 10 L = K + 1, M + A( L, J ) = ZERO + 10 CONTINUE + IF( J.GT.K .AND. J.LE.M ) + $ A( J, J ) = ONE + 20 CONTINUE + END IF +* + DO 40 I = K, 1, -1 +* +* Apply H(i)' to A(i:m,i:n) from the right +* + IF( I.LT.N ) THEN + CALL ZLACGV( N-I, A( I, I+1 ), LDA ) + IF( I.LT.M ) THEN + A( I, I ) = ONE + CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ DCONJG( TAU( I ) ), A( I+1, I ), LDA, WORK ) + END IF + CALL ZSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) + CALL ZLACGV( N-I, A( I, I+1 ), LDA ) + END IF + A( I, I ) = ONE - DCONJG( TAU( I ) ) +* +* Set A(i,1:i-1) to zero +* + DO 30 L = 1, I - 1 + A( I, L ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of ZUNGL2 +* + END diff --git a/2.3-1/src/fortran/lapack/zunglq.f b/2.3-1/src/fortran/lapack/zunglq.f new file mode 100644 index 00000000..ab4a018f --- /dev/null +++ b/2.3-1/src/fortran/lapack/zunglq.f @@ -0,0 +1,215 @@ + SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, + $ LWKOPT, NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNGL2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 ) + LWKOPT = MAX( 1, M )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.M ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNGLQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.LE.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = M + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'ZUNGLQ', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = M + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'ZUNGLQ', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code after the last block. +* The first kk rows are handled by the block method. +* + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) +* +* Set A(kk+1:m,1:kk) to zero. +* + DO 20 J = 1, KK + DO 10 I = KK + 1, M + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* Use unblocked code for the last or only block. +* + IF( KK.LT.M ) + $ CALL ZUNGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, + $ TAU( KK+1 ), WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* Use blocked code +* + DO 50 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF( I+IB.LE.M ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), + $ LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H' to A(i+ib:m,i:n) from the right +* + CALL ZLARFB( 'Right', 'Conjugate transpose', 'Forward', + $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), + $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, + $ WORK( IB+1 ), LDWORK ) + END IF +* +* Apply H' to columns i:n of current block +* + CALL ZUNGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* +* Set columns 1:i-1 of current block to zero +* + DO 40 J = 1, I - 1 + DO 30 L = I, I + IB - 1 + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of ZUNGLQ +* + END diff --git a/2.3-1/src/fortran/lapack/zungql.f b/2.3-1/src/fortran/lapack/zungql.f new file mode 100644 index 00000000..4232abea --- /dev/null +++ b/2.3-1/src/fortran/lapack/zungql.f @@ -0,0 +1,222 @@ + SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, + $ NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2L +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 ) + LWKOPT = N*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNGQL', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'ZUNGQL', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQL', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code after the first block. +* The last kk columns are handled by the block method. +* + KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) +* +* Set A(m-kk+1:m,1:n-kk) to zero. +* + DO 20 J = 1, N - KK + DO 10 I = M - KK + 1, M + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* Use unblocked code for the first or only block. +* + CALL ZUNG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* Use blocked code +* + DO 50 I = K - KK + 1, K, NB + IB = MIN( NB, K-I+1 ) + IF( N-K+I.GT.1 ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i+ib-1) . . . H(i+1) H(i) +* + CALL ZLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, + $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left +* + CALL ZLARFB( 'Left', 'No transpose', 'Backward', + $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, + $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, + $ WORK( IB+1 ), LDWORK ) + END IF +* +* Apply H to rows 1:m-k+i+ib-1 of current block +* + CALL ZUNG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, + $ TAU( I ), WORK, IINFO ) +* +* Set rows m-k+i+ib:m of current block to zero +* + DO 40 J = N - K + I, N - K + I + IB - 1 + DO 30 L = M - K + I + IB, M + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of ZUNGQL +* + END diff --git a/2.3-1/src/fortran/lapack/zungqr.f b/2.3-1/src/fortran/lapack/zungqr.f new file mode 100644 index 00000000..bf5c6997 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zungqr.f @@ -0,0 +1,216 @@ + SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, + $ LWKOPT, NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2R +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) + LWKOPT = MAX( 1, N )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNGQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code after the last block. +* The first kk columns are handled by the block method. +* + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) +* +* Set A(1:kk,kk+1:n) to zero. +* + DO 20 J = KK + 1, N + DO 10 I = 1, KK + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* Use unblocked code for the last or only block. +* + IF( KK.LT.N ) + $ CALL ZUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, + $ TAU( KK+1 ), WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* Use blocked code +* + DO 50 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF( I+IB.LE.N ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, + $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(i:m,i+ib:n) from the left +* + CALL ZLARFB( 'Left', 'No transpose', 'Forward', + $ 'Columnwise', M-I+1, N-I-IB+1, IB, + $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), + $ LDA, WORK( IB+1 ), LDWORK ) + END IF +* +* Apply H to rows i:m of current block +* + CALL ZUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* +* Set rows 1:i-1 of current block to zero +* + DO 40 J = I, I + IB - 1 + DO 30 L = 1, I - 1 + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of ZUNGQR +* + END diff --git a/2.3-1/src/fortran/lapack/zungtr.f b/2.3-1/src/fortran/lapack/zungtr.f new file mode 100644 index 00000000..5de7c109 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zungtr.f @@ -0,0 +1,184 @@ + SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, J, LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZUNGQL, ZUNGQR +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( UPPER ) THEN + NB = ILAENV( 1, 'ZUNGQL', ' ', N-1, N-1, N-1, -1 ) + ELSE + NB = ILAENV( 1, 'ZUNGQR', ' ', N-1, N-1, N-1, -1 ) + END IF + LWKOPT = MAX( 1, N-1 )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNGTR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( UPPER ) THEN +* +* 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 +* + DO 20 J = 1, N - 1 + DO 10 I = 1, J - 1 + A( I, J ) = A( I, J+1 ) + 10 CONTINUE + A( N, J ) = ZERO + 20 CONTINUE + DO 30 I = 1, N - 1 + A( I, N ) = ZERO + 30 CONTINUE + A( N, N ) = ONE +* +* Generate Q(1:n-1,1:n-1) +* + CALL ZUNGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, 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 +* + DO 50 J = N, 2, -1 + A( 1, J ) = ZERO + DO 40 I = J + 1, N + A( I, J ) = A( I, J-1 ) + 40 CONTINUE + 50 CONTINUE + A( 1, 1 ) = ONE + DO 60 I = 2, N + A( I, 1 ) = ZERO + 60 CONTINUE + IF( N.GT.1 ) THEN +* +* Generate Q(2:n,2:n) +* + CALL ZUNGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, + $ LWORK, IINFO ) + END IF + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZUNGTR +* + END diff --git a/2.3-1/src/fortran/lapack/zunm2r.f b/2.3-1/src/fortran/lapack/zunm2r.f new file mode 100644 index 00000000..7d4c067a --- /dev/null +++ b/2.3-1/src/fortran/lapack/zunm2r.f @@ -0,0 +1,201 @@ + SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + COMPLEX*16 AII, TAUI +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNM2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) or H(i)' 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 + END IF +* +* Apply H(i) or H(i)' +* + IF( NOTRAN ) THEN + TAUI = TAU( I ) + ELSE + TAUI = DCONJG( TAU( I ) ) + END IF + AII = A( I, I ) + A( I, I ) = ONE + CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC, + $ WORK ) + A( I, I ) = AII + 10 CONTINUE + RETURN +* +* End of ZUNM2R +* + END diff --git a/2.3-1/src/fortran/lapack/zunmbr.f b/2.3-1/src/fortran/lapack/zunmbr.f new file mode 100644 index 00000000..b32ce338 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zunmbr.f @@ -0,0 +1,288 @@ + SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, + $ LDC, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS, VECT + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN + CHARACTER TRANST + INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZUNMLQ, ZUNMQR +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + APPLYQ = LSAME( VECT, 'Q' ) + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q or P and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + NW = 0 + END IF + IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( K.LT.0 ) THEN + INFO = -6 + ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. + $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) + $ THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( NW.GT.0 ) THEN + IF( APPLYQ ) THEN + IF( LEFT ) THEN + NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1, + $ -1 ) + ELSE + NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1, + $ -1 ) + END IF + ELSE + IF( LEFT ) THEN + NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M-1, N, M-1, + $ -1 ) + ELSE + NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N-1, N-1, + $ -1 ) + END IF + END IF + LWKOPT = MAX( 1, NW*NB ) + ELSE + LWKOPT = 1 + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNMBR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* + IF( APPLYQ ) THEN +* +* Apply Q +* + IF( NQ.GE.K ) THEN +* +* Q was determined by a call to ZGEBRD with nq >= k +* + CALL ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, IINFO ) + ELSE IF( NQ.GT.1 ) THEN +* +* Q was determined by a call to ZGEBRD with nq < k +* + IF( LEFT ) THEN + MI = M - 1 + NI = N + I1 = 2 + I2 = 1 + ELSE + MI = M + NI = N - 1 + I1 = 1 + I2 = 2 + END IF + CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, + $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) + END IF + ELSE +* +* Apply P +* + IF( NOTRAN ) THEN + TRANST = 'C' + ELSE + TRANST = 'N' + END IF + IF( NQ.GT.K ) THEN +* +* P was determined by a call to ZGEBRD with nq > k +* + CALL ZUNMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, IINFO ) + ELSE IF( NQ.GT.1 ) THEN +* +* P was determined by a call to ZGEBRD with nq <= k +* + IF( LEFT ) THEN + MI = M - 1 + NI = N + I1 = 2 + I2 = 1 + ELSE + MI = M + NI = N - 1 + I1 = 1 + I2 = 2 + END IF + CALL ZUNMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, + $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) + END IF + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZUNMBR +* + END diff --git a/2.3-1/src/fortran/lapack/zunml2.f b/2.3-1/src/fortran/lapack/zunml2.f new file mode 100644 index 00000000..cced4a77 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zunml2.f @@ -0,0 +1,205 @@ + SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + COMPLEX*16 AII, TAUI +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLACGV, ZLARF +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNML2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) or H(i)' 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 + END IF +* +* Apply H(i) or H(i)' +* + IF( NOTRAN ) THEN + TAUI = DCONJG( TAU( I ) ) + ELSE + TAUI = TAU( I ) + END IF + IF( I.LT.NQ ) + $ CALL ZLACGV( NQ-I, A( I, I+1 ), LDA ) + AII = A( I, I ) + A( I, I ) = ONE + CALL ZLARF( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC, JC ), + $ LDC, WORK ) + A( I, I ) = AII + IF( I.LT.NQ ) + $ CALL ZLACGV( NQ-I, A( I, I+1 ), LDA ) + 10 CONTINUE + RETURN +* +* End of ZUNML2 +* + END diff --git a/2.3-1/src/fortran/lapack/zunmlq.f b/2.3-1/src/fortran/lapack/zunmlq.f new file mode 100644 index 00000000..b1708757 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zunmlq.f @@ -0,0 +1,267 @@ + SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + CHARACTER TRANST + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + COMPLEX*16 T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNML2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. NB may be at most NBMAX, where NBMAX +* is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNMLQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'ZUNMLQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + IF( NOTRAN ) THEN + TRANST = 'C' + ELSE + TRANST = 'N' + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL ZLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), + $ LDA, TAU( I ), T, LDT ) + IF( LEFT ) THEN +* +* 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 + END IF +* +* Apply H or H' +* + CALL ZLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, + $ A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, WORK, + $ LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZUNMLQ +* + END diff --git a/2.3-1/src/fortran/lapack/zunmqr.f b/2.3-1/src/fortran/lapack/zunmqr.f new file mode 100644 index 00000000..f9b1e98f --- /dev/null +++ b/2.3-1/src/fortran/lapack/zunmqr.f @@ -0,0 +1,260 @@ + SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + COMPLEX*16 T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2R +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. NB may be at most NBMAX, where NBMAX +* is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNMQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL ZLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), + $ LDA, TAU( I ), T, LDT ) + IF( LEFT ) THEN +* +* 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 + END IF +* +* Apply H or H' +* + CALL ZLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, + $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, + $ WORK, LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZUNMQR +* + END diff --git a/2.3-1/src/fortran/lapack/zunmr3.f b/2.3-1/src/fortran/lapack/zunmr3.f new file mode 100644 index 00000000..111c1c95 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zunmr3.f @@ -0,0 +1,212 @@ + SUBROUTINE ZUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, L, LDA, LDC, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ + COMPLEX*16 TAUI +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARZ +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR. + $ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNMR3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JA = M - L + 1 + JC = 1 + ELSE + MI = M + JA = N - L + 1 + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* 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 + END IF +* +* Apply H(i) or H(i)' +* + IF( NOTRAN ) THEN + TAUI = TAU( I ) + ELSE + TAUI = DCONJG( TAU( I ) ) + END IF + CALL ZLARZ( SIDE, MI, NI, L, A( I, JA ), LDA, TAUI, + $ C( IC, JC ), LDC, WORK ) +* + 10 CONTINUE +* + RETURN +* +* End of ZUNMR3 +* + END diff --git a/2.3-1/src/fortran/lapack/zunmrz.f b/2.3-1/src/fortran/lapack/zunmrz.f new file mode 100644 index 00000000..c7637050 --- /dev/null +++ b/2.3-1/src/fortran/lapack/zunmrz.f @@ -0,0 +1,296 @@ + SUBROUTINE ZUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, L, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* 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 .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + CHARACTER TRANST + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JA, JC, + $ LDWORK, LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + COMPLEX*16 T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARZB, ZLARZT, ZUNMR3 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = MAX( 1, N ) + ELSE + NQ = N + NW = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR. + $ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + LWKOPT = 1 +* +* Determine the block size. NB may be at most NBMAX, where +* NBMAX is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'ZUNMRQ', SIDE // TRANS, M, N, + $ K, -1 ) ) + LWKOPT = NW*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNMRZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + RETURN + END IF +* +* Determine the block size. NB may be at most NBMAX, where NBMAX +* is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'ZUNMRQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'ZUNMRQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL ZUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, + $ WORK, IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + JA = M - L + 1 + ELSE + MI = M + IC = 1 + JA = N - L + 1 + END IF +* + IF( NOTRAN ) THEN + TRANST = 'C' + ELSE + TRANST = 'N' + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i+ib-1) . . . H(i+1) H(i) +* + CALL ZLARZT( 'Backward', 'Rowwise', L, IB, A( I, JA ), LDA, + $ TAU( I ), T, LDT ) +* + IF( LEFT ) THEN +* +* 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 + END IF +* +* Apply H or H' +* + CALL ZLARZB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI, + $ IB, L, A( I, JA ), LDA, T, LDT, C( IC, JC ), + $ LDC, WORK, LDWORK ) + 10 CONTINUE +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of ZUNMRZ +* + END -- cgit