From ae570a4ffd97e099c62219da6a2af8c0788a2073 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Fri, 27 Oct 2017 00:37:48 +0200 Subject: [PATCH] Making lapack available to compiled packages --- math/lapack/pom.xml | 3 +- math/lapack/src/main/fortran/Makefile | 567 ++++++ math/lapack/src/main/fortran/dbbcsd.f | 1080 +++++++++++ math/lapack/src/main/fortran/dbdsdc.f | 524 ++++++ math/lapack/src/main/fortran/dbdsqr.f | 850 +++++++++ math/lapack/src/main/fortran/dbdsvdx.f | 792 ++++++++ math/lapack/src/main/fortran/ddisna.f | 245 +++ math/lapack/src/main/fortran/dgbbrd.f | 547 ++++++ math/lapack/src/main/fortran/dgbcon.f | 311 ++++ math/lapack/src/main/fortran/dgbequ.f | 324 ++++ math/lapack/src/main/fortran/dgbequb.f | 340 ++++ math/lapack/src/main/fortran/dgbrfs.f | 464 +++++ math/lapack/src/main/fortran/dgbrfsx.f | 765 ++++++++ math/lapack/src/main/fortran/dgbsv.f | 223 +++ math/lapack/src/main/fortran/dgbsvx.f | 642 +++++++ math/lapack/src/main/fortran/dgbsvxx.f | 799 ++++++++ math/lapack/src/main/fortran/dgbtf2.f | 277 +++ math/lapack/src/main/fortran/dgbtrf.f | 516 ++++++ math/lapack/src/main/fortran/dgbtrs.f | 269 +++ math/lapack/src/main/fortran/dgebak.f | 268 +++ math/lapack/src/main/fortran/dgebal.f | 398 ++++ math/lapack/src/main/fortran/dgebd2.f | 320 ++++ math/lapack/src/main/fortran/dgebrd.f | 353 ++++ math/lapack/src/main/fortran/dgecon.f | 261 +++ math/lapack/src/main/fortran/dgeequ.f | 304 ++++ math/lapack/src/main/fortran/dgeequb.f | 321 ++++ math/lapack/src/main/fortran/dgees.f | 535 ++++++ math/lapack/src/main/fortran/dgeesx.f | 649 +++++++ math/lapack/src/main/fortran/dgeev.f | 529 ++++++ math/lapack/src/main/fortran/dgeevx.f | 694 +++++++ math/lapack/src/main/fortran/dgehd2.f | 225 +++ math/lapack/src/main/fortran/dgehrd.f | 356 ++++ math/lapack/src/main/fortran/dgelq.f | 306 ++++ math/lapack/src/main/fortran/dgelq2.f | 192 ++ math/lapack/src/main/fortran/dgelqf.f | 269 +++ math/lapack/src/main/fortran/dgelqt.f | 210 +++ math/lapack/src/main/fortran/dgelqt3.f | 259 +++ math/lapack/src/main/fortran/dgels.f | 504 +++++ math/lapack/src/main/fortran/dgelsd.f | 629 +++++++ math/lapack/src/main/fortran/dgelss.f | 747 ++++++++ math/lapack/src/main/fortran/dgelsy.f | 479 +++++ math/lapack/src/main/fortran/dgemlq.f | 284 +++ math/lapack/src/main/fortran/dgemlqt.f | 289 +++ math/lapack/src/main/fortran/dgemqr.f | 285 +++ math/lapack/src/main/fortran/dgemqrt.f | 291 +++ math/lapack/src/main/fortran/dgeql2.f | 193 ++ math/lapack/src/main/fortran/dgeqlf.f | 287 +++ math/lapack/src/main/fortran/dgeqp3.f | 361 ++++ math/lapack/src/main/fortran/dgeqr.f | 307 ++++ math/lapack/src/main/fortran/dgeqr2.f | 192 ++ math/lapack/src/main/fortran/dgeqr2p.f | 195 ++ math/lapack/src/main/fortran/dgeqrf.f | 270 +++ math/lapack/src/main/fortran/dgeqrfp.f | 273 +++ math/lapack/src/main/fortran/dgeqrt.f | 218 +++ math/lapack/src/main/fortran/dgeqrt2.f | 227 +++ math/lapack/src/main/fortran/dgeqrt3.f | 257 +++ math/lapack/src/main/fortran/dgerfs.f | 438 +++++ math/lapack/src/main/fortran/dgerfsx.f | 731 ++++++++ math/lapack/src/main/fortran/dgerq2.f | 193 ++ math/lapack/src/main/fortran/dgerqf.f | 287 +++ math/lapack/src/main/fortran/dgesc2.f | 201 ++ math/lapack/src/main/fortran/dgesdd.f | 1548 ++++++++++++++++ math/lapack/src/main/fortran/dgesv.f | 179 ++ math/lapack/src/main/fortran/dgesvdx.f | 834 +++++++++ math/lapack/src/main/fortran/dgesvj.f | 1615 +++++++++++++++++ math/lapack/src/main/fortran/dgesvx.f | 602 ++++++ math/lapack/src/main/fortran/dgesvxx.f | 769 ++++++++ math/lapack/src/main/fortran/dgetc2.f | 234 +++ math/lapack/src/main/fortran/dgetf2.f | 213 +++ math/lapack/src/main/fortran/dgetrf.f | 225 +++ math/lapack/src/main/fortran/dgetrf2.f | 272 +++ math/lapack/src/main/fortran/dgetri.f | 261 +++ math/lapack/src/main/fortran/dgetrs.f | 225 +++ math/lapack/src/main/fortran/dgetsls.f | 494 +++++ math/lapack/src/main/fortran/dggbak.f | 306 ++++ math/lapack/src/main/fortran/dggbal.f | 559 ++++++ math/lapack/src/main/fortran/dgges.f | 682 +++++++ math/lapack/src/main/fortran/dgges3.f | 674 +++++++ math/lapack/src/main/fortran/dggesx.f | 820 +++++++++ math/lapack/src/main/fortran/dggev.f | 592 ++++++ math/lapack/src/main/fortran/dggev3.f | 594 ++++++ math/lapack/src/main/fortran/dggevx.f | 868 +++++++++ math/lapack/src/main/fortran/dggglm.f | 348 ++++ math/lapack/src/main/fortran/dgghd3.f | 896 +++++++++ math/lapack/src/main/fortran/dgghrd.f | 361 ++++ math/lapack/src/main/fortran/dgglse.f | 354 ++++ math/lapack/src/main/fortran/dggqrf.f | 299 +++ math/lapack/src/main/fortran/dggrqf.f | 299 +++ math/lapack/src/main/fortran/dggsvd3.f | 503 +++++ math/lapack/src/main/fortran/dggsvp3.f | 571 ++++++ math/lapack/src/main/fortran/dgsvj0.f | 1078 +++++++++++ math/lapack/src/main/fortran/dgsvj1.f | 783 ++++++++ math/lapack/src/main/fortran/dgtcon.f | 255 +++ math/lapack/src/main/fortran/dgtrfs.f | 474 +++++ math/lapack/src/main/fortran/dgtsv.f | 333 ++++ math/lapack/src/main/fortran/dgtsvx.f | 414 +++++ math/lapack/src/main/fortran/dgttrf.f | 237 +++ math/lapack/src/main/fortran/dgttrs.f | 223 +++ math/lapack/src/main/fortran/dgtts2.f | 274 +++ math/lapack/src/main/fortran/dhgeqz.f | 1367 ++++++++++++++ math/lapack/src/main/fortran/dhsein.f | 530 ++++++ math/lapack/src/main/fortran/dhseqr.f | 516 ++++++ math/lapack/src/main/fortran/disnan.f | 2 +- math/lapack/src/main/fortran/dla_gbamv.f | 411 +++++ math/lapack/src/main/fortran/dla_gbrcond.f | 353 ++++ .../src/main/fortran/dla_gbrfsx_extended.f | 710 ++++++++ math/lapack/src/main/fortran/dla_gbrpvgrw.f | 160 ++ math/lapack/src/main/fortran/dla_geamv.f | 396 ++++ math/lapack/src/main/fortran/dla_gercond.f | 329 ++++ .../src/main/fortran/dla_gerfsx_extended.f | 688 +++++++ math/lapack/src/main/fortran/dla_gerpvgrw.f | 142 ++ math/lapack/src/main/fortran/dla_lin_berr.f | 153 ++ math/lapack/src/main/fortran/dla_porcond.f | 328 ++++ .../src/main/fortran/dla_porfsx_extended.f | 682 +++++++ math/lapack/src/main/fortran/dla_porpvgrw.f | 210 +++ math/lapack/src/main/fortran/dla_syamv.f | 417 +++++ math/lapack/src/main/fortran/dla_syrcond.f | 341 ++++ .../src/main/fortran/dla_syrfsx_extended.f | 711 ++++++++ math/lapack/src/main/fortran/dla_syrpvgrw.f | 320 ++++ math/lapack/src/main/fortran/dla_wwaddw.f | 111 ++ math/lapack/src/main/fortran/dlabad.f | 105 ++ math/lapack/src/main/fortran/dlabrd.f | 381 ++++ math/lapack/src/main/fortran/dlacn2.f | 294 +++ math/lapack/src/main/fortran/dlacon.f | 275 +++ math/lapack/src/main/fortran/dlacpy.f | 156 ++ math/lapack/src/main/fortran/dladiv.f | 256 +++ math/lapack/src/main/fortran/dlae2.f | 185 ++ math/lapack/src/main/fortran/dlaebz.f | 649 +++++++ math/lapack/src/main/fortran/dlaed0.f | 434 +++++ math/lapack/src/main/fortran/dlaed1.f | 274 +++ math/lapack/src/main/fortran/dlaed2.f | 539 ++++++ math/lapack/src/main/fortran/dlaed3.f | 353 ++++ math/lapack/src/main/fortran/dlaed4.f | 917 ++++++++++ math/lapack/src/main/fortran/dlaed5.f | 189 ++ math/lapack/src/main/fortran/dlaed6.f | 410 +++++ math/lapack/src/main/fortran/dlaed7.f | 407 +++++ math/lapack/src/main/fortran/dlaed8.f | 524 ++++++ math/lapack/src/main/fortran/dlaed9.f | 294 +++ math/lapack/src/main/fortran/dlaeda.f | 308 ++++ math/lapack/src/main/fortran/dlaein.f | 632 +++++++ math/lapack/src/main/fortran/dlaev2.f | 238 +++ math/lapack/src/main/fortran/dlaexc.f | 436 +++++ math/lapack/src/main/fortran/dlag2.f | 379 ++++ math/lapack/src/main/fortran/dlag2s.f | 152 ++ math/lapack/src/main/fortran/dlags2.f | 362 ++++ math/lapack/src/main/fortran/dlagtf.f | 266 +++ math/lapack/src/main/fortran/dlagtm.f | 278 +++ math/lapack/src/main/fortran/dlagts.f | 383 ++++ math/lapack/src/main/fortran/dlagv2.f | 374 ++++ math/lapack/src/main/fortran/dlahqr.f | 613 +++++++ math/lapack/src/main/fortran/dlahr2.f | 326 ++++ math/lapack/src/main/fortran/dlaic1.f | 367 ++++ math/lapack/src/main/fortran/dlaisnan.f | 91 + math/lapack/src/main/fortran/dlaln2.f | 611 +++++++ math/lapack/src/main/fortran/dlals0.f | 499 +++++ math/lapack/src/main/fortran/dlalsa.f | 495 +++++ math/lapack/src/main/fortran/dlalsd.f | 523 ++++++ math/lapack/src/main/fortran/dlamrg.f | 171 ++ math/lapack/src/main/fortran/dlamswlq.f | 416 +++++ math/lapack/src/main/fortran/dlamtsqr.f | 415 +++++ math/lapack/src/main/fortran/dlaneg.f | 227 +++ math/lapack/src/main/fortran/dlangb.f | 225 +++ math/lapack/src/main/fortran/dlange.f | 211 +++ math/lapack/src/main/fortran/dlangt.f | 208 +++ math/lapack/src/main/fortran/dlanhs.f | 205 +++ math/lapack/src/main/fortran/dlansb.f | 258 +++ math/lapack/src/main/fortran/dlansf.f | 963 ++++++++++ math/lapack/src/main/fortran/dlansp.f | 261 +++ math/lapack/src/main/fortran/dlanst.f | 186 ++ math/lapack/src/main/fortran/dlansy.f | 241 +++ math/lapack/src/main/fortran/dlantb.f | 361 ++++ math/lapack/src/main/fortran/dlantp.f | 355 ++++ math/lapack/src/main/fortran/dlantr.f | 353 ++++ math/lapack/src/main/fortran/dlanv2.f | 289 +++ math/lapack/src/main/fortran/dlapll.f | 165 ++ math/lapack/src/main/fortran/dlapmr.f | 204 +++ math/lapack/src/main/fortran/dlapmt.f | 203 +++ math/lapack/src/main/fortran/dlapy2.f | 104 ++ math/lapack/src/main/fortran/dlapy3.f | 111 ++ math/lapack/src/main/fortran/dlaqgb.f | 256 +++ math/lapack/src/main/fortran/dlaqge.f | 236 +++ math/lapack/src/main/fortran/dlaqp2.f | 262 +++ math/lapack/src/main/fortran/dlaqps.f | 358 ++++ math/lapack/src/main/fortran/dlaqr0.f | 740 ++++++++ math/lapack/src/main/fortran/dlaqr1.f | 179 ++ math/lapack/src/main/fortran/dlaqr2.f | 684 +++++++ math/lapack/src/main/fortran/dlaqr3.f | 695 +++++++ math/lapack/src/main/fortran/dlaqr4.f | 739 ++++++++ math/lapack/src/main/fortran/dlaqr5.f | 921 ++++++++++ math/lapack/src/main/fortran/dlaqsb.f | 226 +++ math/lapack/src/main/fortran/dlaqsp.f | 212 +++ math/lapack/src/main/fortran/dlaqsy.f | 216 +++ math/lapack/src/main/fortran/dlaqtr.f | 748 ++++++++ math/lapack/src/main/fortran/dlar1v.f | 486 +++++ math/lapack/src/main/fortran/dlar2v.f | 157 ++ math/lapack/src/main/fortran/dlarf.f | 227 +++ math/lapack/src/main/fortran/dlarfb.f | 710 ++++++++ math/lapack/src/main/fortran/dlarfg.f | 196 ++ math/lapack/src/main/fortran/dlarfgp.f | 242 +++ math/lapack/src/main/fortran/dlarft.f | 326 ++++ math/lapack/src/main/fortran/dlarfx.f | 697 +++++++ math/lapack/src/main/fortran/dlarfy.f | 161 ++ math/lapack/src/main/fortran/dlargv.f | 167 ++ math/lapack/src/main/fortran/dlarnv.f | 178 ++ math/lapack/src/main/fortran/dlarra.f | 204 +++ math/lapack/src/main/fortran/dlarrb.f | 401 ++++ math/lapack/src/main/fortran/dlarrc.f | 244 +++ math/lapack/src/main/fortran/dlarrd.f | 863 +++++++++ math/lapack/src/main/fortran/dlarre.f | 899 +++++++++ math/lapack/src/main/fortran/dlarrf.f | 488 +++++ math/lapack/src/main/fortran/dlarrj.f | 373 ++++ math/lapack/src/main/fortran/dlarrk.f | 249 +++ math/lapack/src/main/fortran/dlarrr.f | 204 +++ math/lapack/src/main/fortran/dlarrv.f | 1032 +++++++++++ math/lapack/src/main/fortran/dlarscl2.f | 119 ++ math/lapack/src/main/fortran/dlartg.f | 204 +++ math/lapack/src/main/fortran/dlartgp.f | 202 +++ math/lapack/src/main/fortran/dlartgs.f | 158 ++ math/lapack/src/main/fortran/dlartv.f | 147 ++ math/lapack/src/main/fortran/dlaruv.f | 446 +++++ math/lapack/src/main/fortran/dlarz.f | 236 +++ math/lapack/src/main/fortran/dlarzb.f | 323 ++++ math/lapack/src/main/fortran/dlarzt.f | 264 +++ math/lapack/src/main/fortran/dlas2.f | 183 ++ math/lapack/src/main/fortran/dlascl.f | 368 ++++ math/lapack/src/main/fortran/dlascl2.f | 119 ++ math/lapack/src/main/fortran/dlasd0.f | 318 ++++ math/lapack/src/main/fortran/dlasd1.f | 326 ++++ math/lapack/src/main/fortran/dlasd2.f | 634 +++++++ math/lapack/src/main/fortran/dlasd3.f | 470 +++++ math/lapack/src/main/fortran/dlasd4.f | 1061 +++++++++++ math/lapack/src/main/fortran/dlasd5.f | 231 +++ math/lapack/src/main/fortran/dlasd6.f | 443 +++++ math/lapack/src/main/fortran/dlasd7.f | 580 ++++++ math/lapack/src/main/fortran/dlasd8.f | 342 ++++ math/lapack/src/main/fortran/dlasda.f | 515 ++++++ math/lapack/src/main/fortran/dlasdq.f | 413 +++++ math/lapack/src/main/fortran/dlasdt.f | 172 ++ math/lapack/src/main/fortran/dlaset.f | 184 ++ math/lapack/src/main/fortran/dlasq1.f | 224 +++ math/lapack/src/main/fortran/dlasq2.f | 582 ++++++ math/lapack/src/main/fortran/dlasq3.f | 421 +++++ math/lapack/src/main/fortran/dlasq4.f | 425 +++++ math/lapack/src/main/fortran/dlasq5.f | 410 +++++ math/lapack/src/main/fortran/dlasq6.f | 254 +++ math/lapack/src/main/fortran/dlasr.f | 436 +++++ math/lapack/src/main/fortran/dlasrt.f | 303 ++++ math/lapack/src/main/fortran/dlassq.f | 155 ++ math/lapack/src/main/fortran/dlasv2.f | 325 ++++ math/lapack/src/main/fortran/dlaswlq.f | 258 +++ math/lapack/src/main/fortran/dlaswp.f | 191 ++ math/lapack/src/main/fortran/dlasy2.f | 482 +++++ math/lapack/src/main/fortran/dlasyf.f | 822 +++++++++ math/lapack/src/main/fortran/dlasyf_aa.f | 506 ++++++ math/lapack/src/main/fortran/dlasyf_rk.f | 965 ++++++++++ math/lapack/src/main/fortran/dlasyf_rook.f | 892 +++++++++ math/lapack/src/main/fortran/dlat2s.f | 173 ++ math/lapack/src/main/fortran/dlatbs.f | 812 +++++++++ math/lapack/src/main/fortran/dlatdf.f | 323 ++++ math/lapack/src/main/fortran/dlatps.f | 795 ++++++++ math/lapack/src/main/fortran/dlatrd.f | 336 ++++ math/lapack/src/main/fortran/dlatrs.f | 787 ++++++++ math/lapack/src/main/fortran/dlatrz.f | 200 ++ math/lapack/src/main/fortran/dlatsqr.f | 256 +++ math/lapack/src/main/fortran/dlauu2.f | 198 ++ math/lapack/src/main/fortran/dlauum.f | 218 +++ math/lapack/src/main/fortran/dopgtr.f | 232 +++ math/lapack/src/main/fortran/dopmtr.f | 339 ++++ math/lapack/src/main/fortran/dorbdb.f | 687 +++++++ math/lapack/src/main/fortran/dorbdb1.f | 323 ++++ math/lapack/src/main/fortran/dorbdb2.f | 333 ++++ math/lapack/src/main/fortran/dorbdb3.f | 332 ++++ math/lapack/src/main/fortran/dorbdb4.f | 377 ++++ math/lapack/src/main/fortran/dorbdb5.f | 274 +++ math/lapack/src/main/fortran/dorbdb6.f | 312 ++++ math/lapack/src/main/fortran/dorcsd.f | 616 +++++++ math/lapack/src/main/fortran/dorcsd2by1.f | 740 ++++++++ math/lapack/src/main/fortran/dorg2l.f | 198 ++ math/lapack/src/main/fortran/dorg2r.f | 200 ++ math/lapack/src/main/fortran/dorgbr.f | 337 ++++ math/lapack/src/main/fortran/dorghr.f | 240 +++ math/lapack/src/main/fortran/dorgl2.f | 204 +++ math/lapack/src/main/fortran/dorglq.f | 289 +++ math/lapack/src/main/fortran/dorgql.f | 296 +++ math/lapack/src/main/fortran/dorgqr.f | 290 +++ math/lapack/src/main/fortran/dorgr2.f | 202 +++ math/lapack/src/main/fortran/dorgrq.f | 296 +++ math/lapack/src/main/fortran/dorgtr.f | 255 +++ math/lapack/src/main/fortran/dorm22.f | 441 +++++ math/lapack/src/main/fortran/dorm2l.f | 278 +++ math/lapack/src/main/fortran/dorm2r.f | 282 +++ math/lapack/src/main/fortran/dormbr.f | 372 ++++ math/lapack/src/main/fortran/dormhr.f | 294 +++ math/lapack/src/main/fortran/dorml2.f | 282 +++ math/lapack/src/main/fortran/dormlq.f | 347 ++++ math/lapack/src/main/fortran/dormql.f | 339 ++++ math/lapack/src/main/fortran/dormqr.f | 340 ++++ math/lapack/src/main/fortran/dormr2.f | 278 +++ math/lapack/src/main/fortran/dormr3.f | 299 +++ math/lapack/src/main/fortran/dormrq.f | 346 ++++ math/lapack/src/main/fortran/dormrz.f | 380 ++++ math/lapack/src/main/fortran/dormtr.f | 310 ++++ math/lapack/src/main/fortran/dpbcon.f | 271 +++ math/lapack/src/main/fortran/dpbequ.f | 242 +++ math/lapack/src/main/fortran/dpbrfs.f | 443 +++++ math/lapack/src/main/fortran/dpbstf.f | 319 ++++ math/lapack/src/main/fortran/dpbsv.f | 229 +++ math/lapack/src/main/fortran/dpbsvx.f | 545 ++++++ math/lapack/src/main/fortran/dpbtf2.f | 263 +++ math/lapack/src/main/fortran/dpbtrf.f | 435 +++++ math/lapack/src/main/fortran/dpbtrs.f | 220 +++ math/lapack/src/main/fortran/dpftrf.f | 457 +++++ math/lapack/src/main/fortran/dpftri.f | 423 +++++ math/lapack/src/main/fortran/dpftrs.f | 280 +++ math/lapack/src/main/fortran/dpocon.f | 253 +++ math/lapack/src/main/fortran/dpoequ.f | 205 +++ math/lapack/src/main/fortran/dpoequb.f | 221 +++ math/lapack/src/main/fortran/dporfs.f | 430 +++++ math/lapack/src/main/fortran/dporfsx.f | 693 +++++++ math/lapack/src/main/fortran/dposv.f | 193 ++ math/lapack/src/main/fortran/dposvx.f | 494 +++++ math/lapack/src/main/fortran/dposvxx.f | 683 +++++++ math/lapack/src/main/fortran/dpotf2.f | 230 +++ math/lapack/src/main/fortran/dpotrf.f | 246 +++ math/lapack/src/main/fortran/dpotrf2.f | 237 +++ math/lapack/src/main/fortran/dpotri.f | 159 ++ math/lapack/src/main/fortran/dpotrs.f | 204 +++ math/lapack/src/main/fortran/dppcon.f | 248 +++ math/lapack/src/main/fortran/dppequ.f | 238 +++ math/lapack/src/main/fortran/dpprfs.f | 421 +++++ math/lapack/src/main/fortran/dppsv.f | 205 +++ math/lapack/src/main/fortran/dppsvx.f | 494 +++++ math/lapack/src/main/fortran/dpptrf.f | 240 +++ math/lapack/src/main/fortran/dpptri.f | 188 ++ math/lapack/src/main/fortran/dpptrs.f | 203 +++ math/lapack/src/main/fortran/dptcon.f | 221 +++ math/lapack/src/main/fortran/dpteqr.f | 261 +++ math/lapack/src/main/fortran/dptrfs.f | 395 ++++ math/lapack/src/main/fortran/dptsv.f | 167 ++ math/lapack/src/main/fortran/dptsvx.f | 336 ++++ math/lapack/src/main/fortran/dpttrf.f | 211 +++ math/lapack/src/main/fortran/dpttrs.f | 182 ++ math/lapack/src/main/fortran/dptts2.f | 158 ++ math/lapack/src/main/fortran/drscl.f | 174 ++ math/lapack/src/main/fortran/dsb2st_kernels.f | 335 ++++ math/lapack/src/main/fortran/dsbev.f | 287 +++ math/lapack/src/main/fortran/dsbev_2stage.f | 377 ++++ math/lapack/src/main/fortran/dsbevd.f | 360 ++++ math/lapack/src/main/fortran/dsbevd_2stage.f | 412 +++++ math/lapack/src/main/fortran/dsbevx.f | 543 ++++++ math/lapack/src/main/fortran/dsbevx_2stage.f | 633 +++++++ math/lapack/src/main/fortran/dsbgst.f | 1434 +++++++++++++++ math/lapack/src/main/fortran/dsbgv.f | 280 +++ math/lapack/src/main/fortran/dsbgvd.f | 372 ++++ math/lapack/src/main/fortran/dsbgvx.f | 522 ++++++ math/lapack/src/main/fortran/dsbtrd.f | 641 +++++++ math/lapack/src/main/fortran/dsfrk.f | 544 ++++++ math/lapack/src/main/fortran/dsgesv.f | 433 +++++ math/lapack/src/main/fortran/dspcon.f | 238 +++ math/lapack/src/main/fortran/dspev.f | 262 +++ math/lapack/src/main/fortran/dspevd.f | 338 ++++ math/lapack/src/main/fortran/dspevx.f | 496 +++++ math/lapack/src/main/fortran/dspgst.f | 274 +++ math/lapack/src/main/fortran/dspgv.f | 278 +++ math/lapack/src/main/fortran/dspgvd.f | 364 ++++ math/lapack/src/main/fortran/dspgvx.f | 417 +++++ math/lapack/src/main/fortran/dsposv.f | 439 +++++ math/lapack/src/main/fortran/dsprfs.f | 431 +++++ math/lapack/src/main/fortran/dspsv.f | 224 +++ math/lapack/src/main/fortran/dspsvx.f | 386 ++++ math/lapack/src/main/fortran/dsptrd.f | 300 +++ math/lapack/src/main/fortran/dsptrf.f | 616 +++++++ math/lapack/src/main/fortran/dsptri.f | 401 ++++ math/lapack/src/main/fortran/dsptrs.f | 450 +++++ math/lapack/src/main/fortran/dstebz.f | 771 ++++++++ math/lapack/src/main/fortran/dstedc.f | 483 +++++ math/lapack/src/main/fortran/dstegr.f | 302 +++ math/lapack/src/main/fortran/dstein.f | 453 +++++ math/lapack/src/main/fortran/dstemr.f | 777 ++++++++ math/lapack/src/main/fortran/dsteqr.f | 572 ++++++ math/lapack/src/main/fortran/dsterf.f | 426 +++++ math/lapack/src/main/fortran/dstev.f | 235 +++ math/lapack/src/main/fortran/dstevd.f | 302 +++ math/lapack/src/main/fortran/dstevr.f | 584 ++++++ math/lapack/src/main/fortran/dstevx.f | 464 +++++ math/lapack/src/main/fortran/dsycon.f | 244 +++ math/lapack/src/main/fortran/dsycon_3.f | 285 +++ math/lapack/src/main/fortran/dsycon_rook.f | 258 +++ math/lapack/src/main/fortran/dsyconv.f | 366 ++++ math/lapack/src/main/fortran/dsyconvf.f | 559 ++++++ math/lapack/src/main/fortran/dsyconvf_rook.f | 544 ++++++ math/lapack/src/main/fortran/dsyequb.f | 334 ++++ math/lapack/src/main/fortran/dsyev.f | 286 +++ math/lapack/src/main/fortran/dsyev_2stage.f | 348 ++++ math/lapack/src/main/fortran/dsyevd.f | 357 ++++ math/lapack/src/main/fortran/dsyevd_2stage.f | 406 +++++ math/lapack/src/main/fortran/dsyevr.f | 681 +++++++ math/lapack/src/main/fortran/dsyevr_2stage.f | 740 ++++++++ math/lapack/src/main/fortran/dsyevx.f | 554 ++++++ math/lapack/src/main/fortran/dsyevx_2stage.f | 608 +++++++ math/lapack/src/main/fortran/dsygs2.f | 283 +++ math/lapack/src/main/fortran/dsygst.f | 321 ++++ math/lapack/src/main/fortran/dsygv.f | 314 ++++ math/lapack/src/main/fortran/dsygv_2stage.f | 370 ++++ math/lapack/src/main/fortran/dsygvd.f | 380 ++++ math/lapack/src/main/fortran/dsygvx.f | 465 +++++ math/lapack/src/main/fortran/dsyrfs.f | 441 +++++ math/lapack/src/main/fortran/dsyrfsx.f | 700 +++++++ math/lapack/src/main/fortran/dsysv.f | 270 +++ math/lapack/src/main/fortran/dsysv_aa.f | 256 +++ math/lapack/src/main/fortran/dsysv_rk.f | 317 ++++ math/lapack/src/main/fortran/dsysv_rook.f | 293 +++ math/lapack/src/main/fortran/dsysvx.f | 416 +++++ math/lapack/src/main/fortran/dsysvxx.f | 696 +++++++ math/lapack/src/main/fortran/dsyswapr.f | 193 ++ math/lapack/src/main/fortran/dsytd2.f | 323 ++++ math/lapack/src/main/fortran/dsytf2.f | 610 +++++++ math/lapack/src/main/fortran/dsytf2_rk.f | 943 ++++++++++ math/lapack/src/main/fortran/dsytf2_rook.f | 813 +++++++++ math/lapack/src/main/fortran/dsytrd.f | 376 ++++ math/lapack/src/main/fortran/dsytrd_2stage.f | 337 ++++ math/lapack/src/main/fortran/dsytrd_sb2st.F | 556 ++++++ math/lapack/src/main/fortran/dsytrd_sy2sb.f | 517 ++++++ math/lapack/src/main/fortran/dsytrf.f | 363 ++++ math/lapack/src/main/fortran/dsytrf_aa.f | 480 +++++ math/lapack/src/main/fortran/dsytrf_rk.f | 498 +++++ math/lapack/src/main/fortran/dsytrf_rook.f | 393 ++++ math/lapack/src/main/fortran/dsytri.f | 382 ++++ math/lapack/src/main/fortran/dsytri2.f | 205 +++ math/lapack/src/main/fortran/dsytri2x.f | 591 ++++++ math/lapack/src/main/fortran/dsytri_3.f | 248 +++ math/lapack/src/main/fortran/dsytri_3x.f | 645 +++++++ math/lapack/src/main/fortran/dsytri_rook.f | 450 +++++ math/lapack/src/main/fortran/dsytrs.f | 445 +++++ math/lapack/src/main/fortran/dsytrs2.f | 361 ++++ math/lapack/src/main/fortran/dsytrs_3.f | 371 ++++ math/lapack/src/main/fortran/dsytrs_aa.f | 285 +++ math/lapack/src/main/fortran/dsytrs_rook.f | 484 +++++ math/lapack/src/main/fortran/dtbcon.f | 284 +++ math/lapack/src/main/fortran/dtbrfs.f | 485 +++++ math/lapack/src/main/fortran/dtbtrs.f | 244 +++ math/lapack/src/main/fortran/dtfsm.f | 1006 ++++++++++ math/lapack/src/main/fortran/dtftri.f | 472 +++++ math/lapack/src/main/fortran/dtfttp.f | 517 ++++++ math/lapack/src/main/fortran/dtfttr.f | 495 +++++ math/lapack/src/main/fortran/dtgevc.f | 1211 ++++++++++++ math/lapack/src/main/fortran/dtgex2.f | 697 +++++++ math/lapack/src/main/fortran/dtgexc.f | 544 ++++++ math/lapack/src/main/fortran/dtgsen.f | 866 +++++++++ math/lapack/src/main/fortran/dtgsja.f | 655 +++++++ math/lapack/src/main/fortran/dtgsna.f | 700 +++++++ math/lapack/src/main/fortran/dtgsy2.f | 1075 +++++++++++ math/lapack/src/main/fortran/dtgsyl.f | 682 +++++++ math/lapack/src/main/fortran/dtpcon.f | 267 +++ math/lapack/src/main/fortran/dtplqt.f | 270 +++ math/lapack/src/main/fortran/dtplqt2.f | 312 ++++ math/lapack/src/main/fortran/dtpmlqt.f | 366 ++++ math/lapack/src/main/fortran/dtpmqrt.f | 368 ++++ math/lapack/src/main/fortran/dtpqrt.f | 270 +++ math/lapack/src/main/fortran/dtpqrt2.f | 302 +++ math/lapack/src/main/fortran/dtprfb.f | 811 +++++++++ math/lapack/src/main/fortran/dtprfs.f | 473 +++++ math/lapack/src/main/fortran/dtptri.f | 241 +++ math/lapack/src/main/fortran/dtptrs.f | 228 +++ math/lapack/src/main/fortran/dtpttf.f | 502 +++++ math/lapack/src/main/fortran/dtpttr.f | 176 ++ math/lapack/src/main/fortran/dtrcon.f | 276 +++ math/lapack/src/main/fortran/dtrevc.f | 1076 +++++++++++ math/lapack/src/main/fortran/dtrevc3.f | 1304 +++++++++++++ math/lapack/src/main/fortran/dtrexc.f | 428 +++++ math/lapack/src/main/fortran/dtrrfs.f | 472 +++++ math/lapack/src/main/fortran/dtrsen.f | 570 ++++++ math/lapack/src/main/fortran/dtrsna.f | 603 ++++++ math/lapack/src/main/fortran/dtrsyl.f | 1002 ++++++++++ math/lapack/src/main/fortran/dtrti2.f | 212 +++ math/lapack/src/main/fortran/dtrtri.f | 242 +++ math/lapack/src/main/fortran/dtrtrs.f | 226 +++ math/lapack/src/main/fortran/dtrttf.f | 492 +++++ math/lapack/src/main/fortran/dtrttp.f | 176 ++ math/lapack/src/main/fortran/dtzrzf.f | 313 ++++ math/lapack/src/main/fortran/dzsum1.f | 140 ++ math/lapack/src/main/fortran/icmax1.f | 141 ++ math/lapack/src/main/fortran/ilaclc.f | 118 ++ math/lapack/src/main/fortran/ilaclr.f | 121 ++ math/lapack/src/main/fortran/iladiag.f | 92 + math/lapack/src/main/fortran/iladlc.f | 118 ++ math/lapack/src/main/fortran/iladlr.f | 121 ++ math/lapack/src/main/fortran/ilaprec.f | 98 + math/lapack/src/main/fortran/ilaslc.f | 118 ++ math/lapack/src/main/fortran/ilaslr.f | 121 ++ math/lapack/src/main/fortran/ilatrans.f | 95 + math/lapack/src/main/fortran/ilauplo.f | 92 + math/lapack/src/main/fortran/ilaver.f | 72 + math/lapack/src/main/fortran/ilazlc.f | 118 ++ math/lapack/src/main/fortran/ilazlr.f | 121 ++ math/lapack/src/main/fortran/iparam2stage.F | 386 ++++ math/lapack/src/main/fortran/izmax1.f | 141 ++ math/lapack/src/main/fortran/xerbla.f | 99 + math/lapack/src/main/fortran/xerbla_array.f | 129 ++ .../renjin/gcc/codegen/expr/ExprFactory.java | 1 + .../java/org/renjin/gcc/gimple/GimpleOp.java | 7 + .../org/renjin/gnur/GnurSourcesCompiler.java | 1 - .../main/java/org/renjin/gnur/api/Lapack.java | 2 +- 503 files changed, 199012 insertions(+), 5 deletions(-) create mode 100644 math/lapack/src/main/fortran/Makefile create mode 100644 math/lapack/src/main/fortran/dbbcsd.f create mode 100644 math/lapack/src/main/fortran/dbdsdc.f create mode 100644 math/lapack/src/main/fortran/dbdsqr.f create mode 100644 math/lapack/src/main/fortran/dbdsvdx.f create mode 100644 math/lapack/src/main/fortran/ddisna.f create mode 100644 math/lapack/src/main/fortran/dgbbrd.f create mode 100644 math/lapack/src/main/fortran/dgbcon.f create mode 100644 math/lapack/src/main/fortran/dgbequ.f create mode 100644 math/lapack/src/main/fortran/dgbequb.f create mode 100644 math/lapack/src/main/fortran/dgbrfs.f create mode 100644 math/lapack/src/main/fortran/dgbrfsx.f create mode 100644 math/lapack/src/main/fortran/dgbsv.f create mode 100644 math/lapack/src/main/fortran/dgbsvx.f create mode 100644 math/lapack/src/main/fortran/dgbsvxx.f create mode 100644 math/lapack/src/main/fortran/dgbtf2.f create mode 100644 math/lapack/src/main/fortran/dgbtrf.f create mode 100644 math/lapack/src/main/fortran/dgbtrs.f create mode 100644 math/lapack/src/main/fortran/dgebak.f create mode 100644 math/lapack/src/main/fortran/dgebal.f create mode 100644 math/lapack/src/main/fortran/dgebd2.f create mode 100644 math/lapack/src/main/fortran/dgebrd.f create mode 100644 math/lapack/src/main/fortran/dgecon.f create mode 100644 math/lapack/src/main/fortran/dgeequ.f create mode 100644 math/lapack/src/main/fortran/dgeequb.f create mode 100644 math/lapack/src/main/fortran/dgees.f create mode 100644 math/lapack/src/main/fortran/dgeesx.f create mode 100644 math/lapack/src/main/fortran/dgeev.f create mode 100644 math/lapack/src/main/fortran/dgeevx.f create mode 100644 math/lapack/src/main/fortran/dgehd2.f create mode 100644 math/lapack/src/main/fortran/dgehrd.f create mode 100644 math/lapack/src/main/fortran/dgelq.f create mode 100644 math/lapack/src/main/fortran/dgelq2.f create mode 100644 math/lapack/src/main/fortran/dgelqf.f create mode 100644 math/lapack/src/main/fortran/dgelqt.f create mode 100644 math/lapack/src/main/fortran/dgelqt3.f create mode 100644 math/lapack/src/main/fortran/dgels.f create mode 100644 math/lapack/src/main/fortran/dgelsd.f create mode 100644 math/lapack/src/main/fortran/dgelss.f create mode 100644 math/lapack/src/main/fortran/dgelsy.f create mode 100644 math/lapack/src/main/fortran/dgemlq.f create mode 100644 math/lapack/src/main/fortran/dgemlqt.f create mode 100644 math/lapack/src/main/fortran/dgemqr.f create mode 100644 math/lapack/src/main/fortran/dgemqrt.f create mode 100644 math/lapack/src/main/fortran/dgeql2.f create mode 100644 math/lapack/src/main/fortran/dgeqlf.f create mode 100644 math/lapack/src/main/fortran/dgeqp3.f create mode 100644 math/lapack/src/main/fortran/dgeqr.f create mode 100644 math/lapack/src/main/fortran/dgeqr2.f create mode 100644 math/lapack/src/main/fortran/dgeqr2p.f create mode 100644 math/lapack/src/main/fortran/dgeqrf.f create mode 100644 math/lapack/src/main/fortran/dgeqrfp.f create mode 100644 math/lapack/src/main/fortran/dgeqrt.f create mode 100644 math/lapack/src/main/fortran/dgeqrt2.f create mode 100644 math/lapack/src/main/fortran/dgeqrt3.f create mode 100644 math/lapack/src/main/fortran/dgerfs.f create mode 100644 math/lapack/src/main/fortran/dgerfsx.f create mode 100644 math/lapack/src/main/fortran/dgerq2.f create mode 100644 math/lapack/src/main/fortran/dgerqf.f create mode 100644 math/lapack/src/main/fortran/dgesc2.f create mode 100644 math/lapack/src/main/fortran/dgesdd.f create mode 100644 math/lapack/src/main/fortran/dgesv.f create mode 100644 math/lapack/src/main/fortran/dgesvdx.f create mode 100644 math/lapack/src/main/fortran/dgesvj.f create mode 100644 math/lapack/src/main/fortran/dgesvx.f create mode 100644 math/lapack/src/main/fortran/dgesvxx.f create mode 100644 math/lapack/src/main/fortran/dgetc2.f create mode 100644 math/lapack/src/main/fortran/dgetf2.f create mode 100644 math/lapack/src/main/fortran/dgetrf.f create mode 100644 math/lapack/src/main/fortran/dgetrf2.f create mode 100644 math/lapack/src/main/fortran/dgetri.f create mode 100644 math/lapack/src/main/fortran/dgetrs.f create mode 100644 math/lapack/src/main/fortran/dgetsls.f create mode 100644 math/lapack/src/main/fortran/dggbak.f create mode 100644 math/lapack/src/main/fortran/dggbal.f create mode 100644 math/lapack/src/main/fortran/dgges.f create mode 100644 math/lapack/src/main/fortran/dgges3.f create mode 100644 math/lapack/src/main/fortran/dggesx.f create mode 100644 math/lapack/src/main/fortran/dggev.f create mode 100644 math/lapack/src/main/fortran/dggev3.f create mode 100644 math/lapack/src/main/fortran/dggevx.f create mode 100644 math/lapack/src/main/fortran/dggglm.f create mode 100644 math/lapack/src/main/fortran/dgghd3.f create mode 100644 math/lapack/src/main/fortran/dgghrd.f create mode 100644 math/lapack/src/main/fortran/dgglse.f create mode 100644 math/lapack/src/main/fortran/dggqrf.f create mode 100644 math/lapack/src/main/fortran/dggrqf.f create mode 100644 math/lapack/src/main/fortran/dggsvd3.f create mode 100644 math/lapack/src/main/fortran/dggsvp3.f create mode 100644 math/lapack/src/main/fortran/dgsvj0.f create mode 100644 math/lapack/src/main/fortran/dgsvj1.f create mode 100644 math/lapack/src/main/fortran/dgtcon.f create mode 100644 math/lapack/src/main/fortran/dgtrfs.f create mode 100644 math/lapack/src/main/fortran/dgtsv.f create mode 100644 math/lapack/src/main/fortran/dgtsvx.f create mode 100644 math/lapack/src/main/fortran/dgttrf.f create mode 100644 math/lapack/src/main/fortran/dgttrs.f create mode 100644 math/lapack/src/main/fortran/dgtts2.f create mode 100644 math/lapack/src/main/fortran/dhgeqz.f create mode 100644 math/lapack/src/main/fortran/dhsein.f create mode 100644 math/lapack/src/main/fortran/dhseqr.f create mode 100644 math/lapack/src/main/fortran/dla_gbamv.f create mode 100644 math/lapack/src/main/fortran/dla_gbrcond.f create mode 100644 math/lapack/src/main/fortran/dla_gbrfsx_extended.f create mode 100644 math/lapack/src/main/fortran/dla_gbrpvgrw.f create mode 100644 math/lapack/src/main/fortran/dla_geamv.f create mode 100644 math/lapack/src/main/fortran/dla_gercond.f create mode 100644 math/lapack/src/main/fortran/dla_gerfsx_extended.f create mode 100644 math/lapack/src/main/fortran/dla_gerpvgrw.f create mode 100644 math/lapack/src/main/fortran/dla_lin_berr.f create mode 100644 math/lapack/src/main/fortran/dla_porcond.f create mode 100644 math/lapack/src/main/fortran/dla_porfsx_extended.f create mode 100644 math/lapack/src/main/fortran/dla_porpvgrw.f create mode 100644 math/lapack/src/main/fortran/dla_syamv.f create mode 100644 math/lapack/src/main/fortran/dla_syrcond.f create mode 100644 math/lapack/src/main/fortran/dla_syrfsx_extended.f create mode 100644 math/lapack/src/main/fortran/dla_syrpvgrw.f create mode 100644 math/lapack/src/main/fortran/dla_wwaddw.f create mode 100644 math/lapack/src/main/fortran/dlabad.f create mode 100644 math/lapack/src/main/fortran/dlabrd.f create mode 100644 math/lapack/src/main/fortran/dlacn2.f create mode 100644 math/lapack/src/main/fortran/dlacon.f create mode 100644 math/lapack/src/main/fortran/dlacpy.f create mode 100644 math/lapack/src/main/fortran/dladiv.f create mode 100644 math/lapack/src/main/fortran/dlae2.f create mode 100644 math/lapack/src/main/fortran/dlaebz.f create mode 100644 math/lapack/src/main/fortran/dlaed0.f create mode 100644 math/lapack/src/main/fortran/dlaed1.f create mode 100644 math/lapack/src/main/fortran/dlaed2.f create mode 100644 math/lapack/src/main/fortran/dlaed3.f create mode 100644 math/lapack/src/main/fortran/dlaed4.f create mode 100644 math/lapack/src/main/fortran/dlaed5.f create mode 100644 math/lapack/src/main/fortran/dlaed6.f create mode 100644 math/lapack/src/main/fortran/dlaed7.f create mode 100644 math/lapack/src/main/fortran/dlaed8.f create mode 100644 math/lapack/src/main/fortran/dlaed9.f create mode 100644 math/lapack/src/main/fortran/dlaeda.f create mode 100644 math/lapack/src/main/fortran/dlaein.f create mode 100644 math/lapack/src/main/fortran/dlaev2.f create mode 100644 math/lapack/src/main/fortran/dlaexc.f create mode 100644 math/lapack/src/main/fortran/dlag2.f create mode 100644 math/lapack/src/main/fortran/dlag2s.f create mode 100644 math/lapack/src/main/fortran/dlags2.f create mode 100644 math/lapack/src/main/fortran/dlagtf.f create mode 100644 math/lapack/src/main/fortran/dlagtm.f create mode 100644 math/lapack/src/main/fortran/dlagts.f create mode 100644 math/lapack/src/main/fortran/dlagv2.f create mode 100644 math/lapack/src/main/fortran/dlahqr.f create mode 100644 math/lapack/src/main/fortran/dlahr2.f create mode 100644 math/lapack/src/main/fortran/dlaic1.f create mode 100644 math/lapack/src/main/fortran/dlaisnan.f create mode 100644 math/lapack/src/main/fortran/dlaln2.f create mode 100644 math/lapack/src/main/fortran/dlals0.f create mode 100644 math/lapack/src/main/fortran/dlalsa.f create mode 100644 math/lapack/src/main/fortran/dlalsd.f create mode 100644 math/lapack/src/main/fortran/dlamrg.f create mode 100644 math/lapack/src/main/fortran/dlamswlq.f create mode 100644 math/lapack/src/main/fortran/dlamtsqr.f create mode 100644 math/lapack/src/main/fortran/dlaneg.f create mode 100644 math/lapack/src/main/fortran/dlangb.f create mode 100644 math/lapack/src/main/fortran/dlange.f create mode 100644 math/lapack/src/main/fortran/dlangt.f create mode 100644 math/lapack/src/main/fortran/dlanhs.f create mode 100644 math/lapack/src/main/fortran/dlansb.f create mode 100644 math/lapack/src/main/fortran/dlansf.f create mode 100644 math/lapack/src/main/fortran/dlansp.f create mode 100644 math/lapack/src/main/fortran/dlanst.f create mode 100644 math/lapack/src/main/fortran/dlansy.f create mode 100644 math/lapack/src/main/fortran/dlantb.f create mode 100644 math/lapack/src/main/fortran/dlantp.f create mode 100644 math/lapack/src/main/fortran/dlantr.f create mode 100644 math/lapack/src/main/fortran/dlanv2.f create mode 100644 math/lapack/src/main/fortran/dlapll.f create mode 100644 math/lapack/src/main/fortran/dlapmr.f create mode 100644 math/lapack/src/main/fortran/dlapmt.f create mode 100644 math/lapack/src/main/fortran/dlapy2.f create mode 100644 math/lapack/src/main/fortran/dlapy3.f create mode 100644 math/lapack/src/main/fortran/dlaqgb.f create mode 100644 math/lapack/src/main/fortran/dlaqge.f create mode 100644 math/lapack/src/main/fortran/dlaqp2.f create mode 100644 math/lapack/src/main/fortran/dlaqps.f create mode 100644 math/lapack/src/main/fortran/dlaqr0.f create mode 100644 math/lapack/src/main/fortran/dlaqr1.f create mode 100644 math/lapack/src/main/fortran/dlaqr2.f create mode 100644 math/lapack/src/main/fortran/dlaqr3.f create mode 100644 math/lapack/src/main/fortran/dlaqr4.f create mode 100644 math/lapack/src/main/fortran/dlaqr5.f create mode 100644 math/lapack/src/main/fortran/dlaqsb.f create mode 100644 math/lapack/src/main/fortran/dlaqsp.f create mode 100644 math/lapack/src/main/fortran/dlaqsy.f create mode 100644 math/lapack/src/main/fortran/dlaqtr.f create mode 100644 math/lapack/src/main/fortran/dlar1v.f create mode 100644 math/lapack/src/main/fortran/dlar2v.f create mode 100644 math/lapack/src/main/fortran/dlarf.f create mode 100644 math/lapack/src/main/fortran/dlarfb.f create mode 100644 math/lapack/src/main/fortran/dlarfg.f create mode 100644 math/lapack/src/main/fortran/dlarfgp.f create mode 100644 math/lapack/src/main/fortran/dlarft.f create mode 100644 math/lapack/src/main/fortran/dlarfx.f create mode 100644 math/lapack/src/main/fortran/dlarfy.f create mode 100644 math/lapack/src/main/fortran/dlargv.f create mode 100644 math/lapack/src/main/fortran/dlarnv.f create mode 100644 math/lapack/src/main/fortran/dlarra.f create mode 100644 math/lapack/src/main/fortran/dlarrb.f create mode 100644 math/lapack/src/main/fortran/dlarrc.f create mode 100644 math/lapack/src/main/fortran/dlarrd.f create mode 100644 math/lapack/src/main/fortran/dlarre.f create mode 100644 math/lapack/src/main/fortran/dlarrf.f create mode 100644 math/lapack/src/main/fortran/dlarrj.f create mode 100644 math/lapack/src/main/fortran/dlarrk.f create mode 100644 math/lapack/src/main/fortran/dlarrr.f create mode 100644 math/lapack/src/main/fortran/dlarrv.f create mode 100644 math/lapack/src/main/fortran/dlarscl2.f create mode 100644 math/lapack/src/main/fortran/dlartg.f create mode 100644 math/lapack/src/main/fortran/dlartgp.f create mode 100644 math/lapack/src/main/fortran/dlartgs.f create mode 100644 math/lapack/src/main/fortran/dlartv.f create mode 100644 math/lapack/src/main/fortran/dlaruv.f create mode 100644 math/lapack/src/main/fortran/dlarz.f create mode 100644 math/lapack/src/main/fortran/dlarzb.f create mode 100644 math/lapack/src/main/fortran/dlarzt.f create mode 100644 math/lapack/src/main/fortran/dlas2.f create mode 100644 math/lapack/src/main/fortran/dlascl.f create mode 100644 math/lapack/src/main/fortran/dlascl2.f create mode 100644 math/lapack/src/main/fortran/dlasd0.f create mode 100644 math/lapack/src/main/fortran/dlasd1.f create mode 100644 math/lapack/src/main/fortran/dlasd2.f create mode 100644 math/lapack/src/main/fortran/dlasd3.f create mode 100644 math/lapack/src/main/fortran/dlasd4.f create mode 100644 math/lapack/src/main/fortran/dlasd5.f create mode 100644 math/lapack/src/main/fortran/dlasd6.f create mode 100644 math/lapack/src/main/fortran/dlasd7.f create mode 100644 math/lapack/src/main/fortran/dlasd8.f create mode 100644 math/lapack/src/main/fortran/dlasda.f create mode 100644 math/lapack/src/main/fortran/dlasdq.f create mode 100644 math/lapack/src/main/fortran/dlasdt.f create mode 100644 math/lapack/src/main/fortran/dlaset.f create mode 100644 math/lapack/src/main/fortran/dlasq1.f create mode 100644 math/lapack/src/main/fortran/dlasq2.f create mode 100644 math/lapack/src/main/fortran/dlasq3.f create mode 100644 math/lapack/src/main/fortran/dlasq4.f create mode 100644 math/lapack/src/main/fortran/dlasq5.f create mode 100644 math/lapack/src/main/fortran/dlasq6.f create mode 100644 math/lapack/src/main/fortran/dlasr.f create mode 100644 math/lapack/src/main/fortran/dlasrt.f create mode 100644 math/lapack/src/main/fortran/dlassq.f create mode 100644 math/lapack/src/main/fortran/dlasv2.f create mode 100644 math/lapack/src/main/fortran/dlaswlq.f create mode 100644 math/lapack/src/main/fortran/dlaswp.f create mode 100644 math/lapack/src/main/fortran/dlasy2.f create mode 100644 math/lapack/src/main/fortran/dlasyf.f create mode 100644 math/lapack/src/main/fortran/dlasyf_aa.f create mode 100644 math/lapack/src/main/fortran/dlasyf_rk.f create mode 100644 math/lapack/src/main/fortran/dlasyf_rook.f create mode 100644 math/lapack/src/main/fortran/dlat2s.f create mode 100644 math/lapack/src/main/fortran/dlatbs.f create mode 100644 math/lapack/src/main/fortran/dlatdf.f create mode 100644 math/lapack/src/main/fortran/dlatps.f create mode 100644 math/lapack/src/main/fortran/dlatrd.f create mode 100644 math/lapack/src/main/fortran/dlatrs.f create mode 100644 math/lapack/src/main/fortran/dlatrz.f create mode 100644 math/lapack/src/main/fortran/dlatsqr.f create mode 100644 math/lapack/src/main/fortran/dlauu2.f create mode 100644 math/lapack/src/main/fortran/dlauum.f create mode 100644 math/lapack/src/main/fortran/dopgtr.f create mode 100644 math/lapack/src/main/fortran/dopmtr.f create mode 100644 math/lapack/src/main/fortran/dorbdb.f create mode 100644 math/lapack/src/main/fortran/dorbdb1.f create mode 100644 math/lapack/src/main/fortran/dorbdb2.f create mode 100644 math/lapack/src/main/fortran/dorbdb3.f create mode 100644 math/lapack/src/main/fortran/dorbdb4.f create mode 100644 math/lapack/src/main/fortran/dorbdb5.f create mode 100644 math/lapack/src/main/fortran/dorbdb6.f create mode 100644 math/lapack/src/main/fortran/dorcsd.f create mode 100644 math/lapack/src/main/fortran/dorcsd2by1.f create mode 100644 math/lapack/src/main/fortran/dorg2l.f create mode 100644 math/lapack/src/main/fortran/dorg2r.f create mode 100644 math/lapack/src/main/fortran/dorgbr.f create mode 100644 math/lapack/src/main/fortran/dorghr.f create mode 100644 math/lapack/src/main/fortran/dorgl2.f create mode 100644 math/lapack/src/main/fortran/dorglq.f create mode 100644 math/lapack/src/main/fortran/dorgql.f create mode 100644 math/lapack/src/main/fortran/dorgqr.f create mode 100644 math/lapack/src/main/fortran/dorgr2.f create mode 100644 math/lapack/src/main/fortran/dorgrq.f create mode 100644 math/lapack/src/main/fortran/dorgtr.f create mode 100644 math/lapack/src/main/fortran/dorm22.f create mode 100644 math/lapack/src/main/fortran/dorm2l.f create mode 100644 math/lapack/src/main/fortran/dorm2r.f create mode 100644 math/lapack/src/main/fortran/dormbr.f create mode 100644 math/lapack/src/main/fortran/dormhr.f create mode 100644 math/lapack/src/main/fortran/dorml2.f create mode 100644 math/lapack/src/main/fortran/dormlq.f create mode 100644 math/lapack/src/main/fortran/dormql.f create mode 100644 math/lapack/src/main/fortran/dormqr.f create mode 100644 math/lapack/src/main/fortran/dormr2.f create mode 100644 math/lapack/src/main/fortran/dormr3.f create mode 100644 math/lapack/src/main/fortran/dormrq.f create mode 100644 math/lapack/src/main/fortran/dormrz.f create mode 100644 math/lapack/src/main/fortran/dormtr.f create mode 100644 math/lapack/src/main/fortran/dpbcon.f create mode 100644 math/lapack/src/main/fortran/dpbequ.f create mode 100644 math/lapack/src/main/fortran/dpbrfs.f create mode 100644 math/lapack/src/main/fortran/dpbstf.f create mode 100644 math/lapack/src/main/fortran/dpbsv.f create mode 100644 math/lapack/src/main/fortran/dpbsvx.f create mode 100644 math/lapack/src/main/fortran/dpbtf2.f create mode 100644 math/lapack/src/main/fortran/dpbtrf.f create mode 100644 math/lapack/src/main/fortran/dpbtrs.f create mode 100644 math/lapack/src/main/fortran/dpftrf.f create mode 100644 math/lapack/src/main/fortran/dpftri.f create mode 100644 math/lapack/src/main/fortran/dpftrs.f create mode 100644 math/lapack/src/main/fortran/dpocon.f create mode 100644 math/lapack/src/main/fortran/dpoequ.f create mode 100644 math/lapack/src/main/fortran/dpoequb.f create mode 100644 math/lapack/src/main/fortran/dporfs.f create mode 100644 math/lapack/src/main/fortran/dporfsx.f create mode 100644 math/lapack/src/main/fortran/dposv.f create mode 100644 math/lapack/src/main/fortran/dposvx.f create mode 100644 math/lapack/src/main/fortran/dposvxx.f create mode 100644 math/lapack/src/main/fortran/dpotf2.f create mode 100644 math/lapack/src/main/fortran/dpotrf.f create mode 100644 math/lapack/src/main/fortran/dpotrf2.f create mode 100644 math/lapack/src/main/fortran/dpotri.f create mode 100644 math/lapack/src/main/fortran/dpotrs.f create mode 100644 math/lapack/src/main/fortran/dppcon.f create mode 100644 math/lapack/src/main/fortran/dppequ.f create mode 100644 math/lapack/src/main/fortran/dpprfs.f create mode 100644 math/lapack/src/main/fortran/dppsv.f create mode 100644 math/lapack/src/main/fortran/dppsvx.f create mode 100644 math/lapack/src/main/fortran/dpptrf.f create mode 100644 math/lapack/src/main/fortran/dpptri.f create mode 100644 math/lapack/src/main/fortran/dpptrs.f create mode 100644 math/lapack/src/main/fortran/dptcon.f create mode 100644 math/lapack/src/main/fortran/dpteqr.f create mode 100644 math/lapack/src/main/fortran/dptrfs.f create mode 100644 math/lapack/src/main/fortran/dptsv.f create mode 100644 math/lapack/src/main/fortran/dptsvx.f create mode 100644 math/lapack/src/main/fortran/dpttrf.f create mode 100644 math/lapack/src/main/fortran/dpttrs.f create mode 100644 math/lapack/src/main/fortran/dptts2.f create mode 100644 math/lapack/src/main/fortran/drscl.f create mode 100644 math/lapack/src/main/fortran/dsb2st_kernels.f create mode 100644 math/lapack/src/main/fortran/dsbev.f create mode 100644 math/lapack/src/main/fortran/dsbev_2stage.f create mode 100644 math/lapack/src/main/fortran/dsbevd.f create mode 100644 math/lapack/src/main/fortran/dsbevd_2stage.f create mode 100644 math/lapack/src/main/fortran/dsbevx.f create mode 100644 math/lapack/src/main/fortran/dsbevx_2stage.f create mode 100644 math/lapack/src/main/fortran/dsbgst.f create mode 100644 math/lapack/src/main/fortran/dsbgv.f create mode 100644 math/lapack/src/main/fortran/dsbgvd.f create mode 100644 math/lapack/src/main/fortran/dsbgvx.f create mode 100644 math/lapack/src/main/fortran/dsbtrd.f create mode 100644 math/lapack/src/main/fortran/dsfrk.f create mode 100644 math/lapack/src/main/fortran/dsgesv.f create mode 100644 math/lapack/src/main/fortran/dspcon.f create mode 100644 math/lapack/src/main/fortran/dspev.f create mode 100644 math/lapack/src/main/fortran/dspevd.f create mode 100644 math/lapack/src/main/fortran/dspevx.f create mode 100644 math/lapack/src/main/fortran/dspgst.f create mode 100644 math/lapack/src/main/fortran/dspgv.f create mode 100644 math/lapack/src/main/fortran/dspgvd.f create mode 100644 math/lapack/src/main/fortran/dspgvx.f create mode 100644 math/lapack/src/main/fortran/dsposv.f create mode 100644 math/lapack/src/main/fortran/dsprfs.f create mode 100644 math/lapack/src/main/fortran/dspsv.f create mode 100644 math/lapack/src/main/fortran/dspsvx.f create mode 100644 math/lapack/src/main/fortran/dsptrd.f create mode 100644 math/lapack/src/main/fortran/dsptrf.f create mode 100644 math/lapack/src/main/fortran/dsptri.f create mode 100644 math/lapack/src/main/fortran/dsptrs.f create mode 100644 math/lapack/src/main/fortran/dstebz.f create mode 100644 math/lapack/src/main/fortran/dstedc.f create mode 100644 math/lapack/src/main/fortran/dstegr.f create mode 100644 math/lapack/src/main/fortran/dstein.f create mode 100644 math/lapack/src/main/fortran/dstemr.f create mode 100644 math/lapack/src/main/fortran/dsteqr.f create mode 100644 math/lapack/src/main/fortran/dsterf.f create mode 100644 math/lapack/src/main/fortran/dstev.f create mode 100644 math/lapack/src/main/fortran/dstevd.f create mode 100644 math/lapack/src/main/fortran/dstevr.f create mode 100644 math/lapack/src/main/fortran/dstevx.f create mode 100644 math/lapack/src/main/fortran/dsycon.f create mode 100644 math/lapack/src/main/fortran/dsycon_3.f create mode 100644 math/lapack/src/main/fortran/dsycon_rook.f create mode 100644 math/lapack/src/main/fortran/dsyconv.f create mode 100644 math/lapack/src/main/fortran/dsyconvf.f create mode 100644 math/lapack/src/main/fortran/dsyconvf_rook.f create mode 100644 math/lapack/src/main/fortran/dsyequb.f create mode 100644 math/lapack/src/main/fortran/dsyev.f create mode 100644 math/lapack/src/main/fortran/dsyev_2stage.f create mode 100644 math/lapack/src/main/fortran/dsyevd.f create mode 100644 math/lapack/src/main/fortran/dsyevd_2stage.f create mode 100644 math/lapack/src/main/fortran/dsyevr.f create mode 100644 math/lapack/src/main/fortran/dsyevr_2stage.f create mode 100644 math/lapack/src/main/fortran/dsyevx.f create mode 100644 math/lapack/src/main/fortran/dsyevx_2stage.f create mode 100644 math/lapack/src/main/fortran/dsygs2.f create mode 100644 math/lapack/src/main/fortran/dsygst.f create mode 100644 math/lapack/src/main/fortran/dsygv.f create mode 100644 math/lapack/src/main/fortran/dsygv_2stage.f create mode 100644 math/lapack/src/main/fortran/dsygvd.f create mode 100644 math/lapack/src/main/fortran/dsygvx.f create mode 100644 math/lapack/src/main/fortran/dsyrfs.f create mode 100644 math/lapack/src/main/fortran/dsyrfsx.f create mode 100644 math/lapack/src/main/fortran/dsysv.f create mode 100644 math/lapack/src/main/fortran/dsysv_aa.f create mode 100644 math/lapack/src/main/fortran/dsysv_rk.f create mode 100644 math/lapack/src/main/fortran/dsysv_rook.f create mode 100644 math/lapack/src/main/fortran/dsysvx.f create mode 100644 math/lapack/src/main/fortran/dsysvxx.f create mode 100644 math/lapack/src/main/fortran/dsyswapr.f create mode 100644 math/lapack/src/main/fortran/dsytd2.f create mode 100644 math/lapack/src/main/fortran/dsytf2.f create mode 100644 math/lapack/src/main/fortran/dsytf2_rk.f create mode 100644 math/lapack/src/main/fortran/dsytf2_rook.f create mode 100644 math/lapack/src/main/fortran/dsytrd.f create mode 100644 math/lapack/src/main/fortran/dsytrd_2stage.f create mode 100644 math/lapack/src/main/fortran/dsytrd_sb2st.F create mode 100644 math/lapack/src/main/fortran/dsytrd_sy2sb.f create mode 100644 math/lapack/src/main/fortran/dsytrf.f create mode 100644 math/lapack/src/main/fortran/dsytrf_aa.f create mode 100644 math/lapack/src/main/fortran/dsytrf_rk.f create mode 100644 math/lapack/src/main/fortran/dsytrf_rook.f create mode 100644 math/lapack/src/main/fortran/dsytri.f create mode 100644 math/lapack/src/main/fortran/dsytri2.f create mode 100644 math/lapack/src/main/fortran/dsytri2x.f create mode 100644 math/lapack/src/main/fortran/dsytri_3.f create mode 100644 math/lapack/src/main/fortran/dsytri_3x.f create mode 100644 math/lapack/src/main/fortran/dsytri_rook.f create mode 100644 math/lapack/src/main/fortran/dsytrs.f create mode 100644 math/lapack/src/main/fortran/dsytrs2.f create mode 100644 math/lapack/src/main/fortran/dsytrs_3.f create mode 100644 math/lapack/src/main/fortran/dsytrs_aa.f create mode 100644 math/lapack/src/main/fortran/dsytrs_rook.f create mode 100644 math/lapack/src/main/fortran/dtbcon.f create mode 100644 math/lapack/src/main/fortran/dtbrfs.f create mode 100644 math/lapack/src/main/fortran/dtbtrs.f create mode 100644 math/lapack/src/main/fortran/dtfsm.f create mode 100644 math/lapack/src/main/fortran/dtftri.f create mode 100644 math/lapack/src/main/fortran/dtfttp.f create mode 100644 math/lapack/src/main/fortran/dtfttr.f create mode 100644 math/lapack/src/main/fortran/dtgevc.f create mode 100644 math/lapack/src/main/fortran/dtgex2.f create mode 100644 math/lapack/src/main/fortran/dtgexc.f create mode 100644 math/lapack/src/main/fortran/dtgsen.f create mode 100644 math/lapack/src/main/fortran/dtgsja.f create mode 100644 math/lapack/src/main/fortran/dtgsna.f create mode 100644 math/lapack/src/main/fortran/dtgsy2.f create mode 100644 math/lapack/src/main/fortran/dtgsyl.f create mode 100644 math/lapack/src/main/fortran/dtpcon.f create mode 100644 math/lapack/src/main/fortran/dtplqt.f create mode 100644 math/lapack/src/main/fortran/dtplqt2.f create mode 100644 math/lapack/src/main/fortran/dtpmlqt.f create mode 100644 math/lapack/src/main/fortran/dtpmqrt.f create mode 100644 math/lapack/src/main/fortran/dtpqrt.f create mode 100644 math/lapack/src/main/fortran/dtpqrt2.f create mode 100644 math/lapack/src/main/fortran/dtprfb.f create mode 100644 math/lapack/src/main/fortran/dtprfs.f create mode 100644 math/lapack/src/main/fortran/dtptri.f create mode 100644 math/lapack/src/main/fortran/dtptrs.f create mode 100644 math/lapack/src/main/fortran/dtpttf.f create mode 100644 math/lapack/src/main/fortran/dtpttr.f create mode 100644 math/lapack/src/main/fortran/dtrcon.f create mode 100644 math/lapack/src/main/fortran/dtrevc.f create mode 100644 math/lapack/src/main/fortran/dtrevc3.f create mode 100644 math/lapack/src/main/fortran/dtrexc.f create mode 100644 math/lapack/src/main/fortran/dtrrfs.f create mode 100644 math/lapack/src/main/fortran/dtrsen.f create mode 100644 math/lapack/src/main/fortran/dtrsna.f create mode 100644 math/lapack/src/main/fortran/dtrsyl.f create mode 100644 math/lapack/src/main/fortran/dtrti2.f create mode 100644 math/lapack/src/main/fortran/dtrtri.f create mode 100644 math/lapack/src/main/fortran/dtrtrs.f create mode 100644 math/lapack/src/main/fortran/dtrttf.f create mode 100644 math/lapack/src/main/fortran/dtrttp.f create mode 100644 math/lapack/src/main/fortran/dtzrzf.f create mode 100644 math/lapack/src/main/fortran/dzsum1.f create mode 100644 math/lapack/src/main/fortran/icmax1.f create mode 100644 math/lapack/src/main/fortran/ilaclc.f create mode 100644 math/lapack/src/main/fortran/ilaclr.f create mode 100644 math/lapack/src/main/fortran/iladiag.f create mode 100644 math/lapack/src/main/fortran/iladlc.f create mode 100644 math/lapack/src/main/fortran/iladlr.f create mode 100644 math/lapack/src/main/fortran/ilaprec.f create mode 100644 math/lapack/src/main/fortran/ilaslc.f create mode 100644 math/lapack/src/main/fortran/ilaslr.f create mode 100644 math/lapack/src/main/fortran/ilatrans.f create mode 100644 math/lapack/src/main/fortran/ilauplo.f create mode 100644 math/lapack/src/main/fortran/ilaver.f create mode 100644 math/lapack/src/main/fortran/ilazlc.f create mode 100644 math/lapack/src/main/fortran/ilazlr.f create mode 100644 math/lapack/src/main/fortran/iparam2stage.F create mode 100644 math/lapack/src/main/fortran/izmax1.f create mode 100644 math/lapack/src/main/fortran/xerbla.f create mode 100644 math/lapack/src/main/fortran/xerbla_array.f diff --git a/math/lapack/pom.xml b/math/lapack/pom.xml index c08fcfc457..0672d1c754 100644 --- a/math/lapack/pom.xml +++ b/math/lapack/pom.xml @@ -51,8 +51,7 @@ gcc-bridge-maven-plugin ${project.version} - org.renjin.math - Lapack + org.renjin.math.lapack diff --git a/math/lapack/src/main/fortran/Makefile b/math/lapack/src/main/fortran/Makefile new file mode 100644 index 0000000000..e5703733a7 --- /dev/null +++ b/math/lapack/src/main/fortran/Makefile @@ -0,0 +1,567 @@ +include ../make.inc + +####################################################################### +# This is the makefile to create a library for LAPACK. +# The files are organized as follows: +# ALLAUX -- Auxiliary routines called from all precisions +# +# SCLAUX -- Auxiliary routines called from both REAL and COMPLEX. +# DZLAUX -- Auxiliary routines called from both DOUBLE and COMPLEX*16. +# +# DSLASRC -- Double-single mixed precision real routines called from +# single, single-extra and double precision real LAPACK +# routines (i.e. from SLASRC, SXLASRC, DLASRC). +# ZCLASRC -- Double-single mixed precision complex routines called from +# single, single-extra and double precision complex LAPACK +# routines (i.e. from CLASRC, CXLASRC, ZLASRC). +# +# SLASRC -- Single precision real LAPACK routines +# SXLASRC -- Single precision real LAPACK routines using extra +# precision. +# CLASRC -- Single precision complex LAPACK routines +# CXLASRC -- Single precision complex LAPACK routines using extra +# precision. +# DLASRC -- Double precision real LAPACK routines +# DXLASRC -- Double precision real LAPACK routines using extra +# precision. +# ZLASRC -- Double precision complex LAPACK routines +# ZXLASRC -- Double precision complex LAPACK routines using extra +# precision. +# +# DEPRECATED -- Deprecated routines in all precisions +# +# The library can be set up to include routines for any combination +# of the four precisions. To create or add to the library, enter make +# followed by one or more of the precisions desired. Some examples: +# make single +# make single complex +# make single double complex complex16 +# Alternatively, the command +# make +# without any arguments creates a library of all four precisions. +# The library is called +# lapack.a +# and is created at the next higher directory level. +# +# To remove the object files after the library is created, enter +# make clean +# On some systems, you can force the source files to be recompiled by +# entering (for example) +# make single FRC=FRC +# +# ***Note*** +# The functions lsame, second, dsecnd, slamch, and dlamch may have +# to be installed before compiling the library. Refer to the +# installation guide, LAPACK Working Note 41, for instructions. +# +####################################################################### + +ALLAUX = ilaenv.o ieeeck.o lsamen.o xerbla.o xerbla_array.o iparmq.o iparam2stage.o\ + ilaprec.o ilatrans.o ilauplo.o iladiag.o chla_transtype.o \ + ../INSTALL/ilaver.o ../INSTALL/lsame.o ../INSTALL/slamch.o + +SCLAUX = \ + sbdsdc.o \ + sbdsqr.o sdisna.o slabad.o slacpy.o sladiv.o slae2.o slaebz.o \ + slaed0.o slaed1.o slaed2.o slaed3.o slaed4.o slaed5.o slaed6.o \ + slaed7.o slaed8.o slaed9.o slaeda.o slaev2.o slagtf.o \ + slagts.o slamrg.o slanst.o \ + slapy2.o slapy3.o slarnv.o \ + slarra.o slarrb.o slarrc.o slarrd.o slarre.o slarrf.o slarrj.o \ + slarrk.o slarrr.o slaneg.o \ + slartg.o slaruv.o slas2.o slascl.o \ + slasd0.o slasd1.o slasd2.o slasd3.o slasd4.o slasd5.o slasd6.o \ + slasd7.o slasd8.o slasda.o slasdq.o slasdt.o \ + slaset.o slasq1.o slasq2.o slasq3.o slasq4.o slasq5.o slasq6.o \ + slasr.o slasrt.o slassq.o slasv2.o spttrf.o sstebz.o sstedc.o \ + ssteqr.o ssterf.o slaisnan.o sisnan.o \ + slartgp.o slartgs.o \ + ../INSTALL/second_$(TIMER).o + +DZLAUX = \ + dbdsdc.o \ + dbdsqr.o ddisna.o dlabad.o dlacpy.o dladiv.o dlae2.o dlaebz.o \ + dlaed0.o dlaed1.o dlaed2.o dlaed3.o dlaed4.o dlaed5.o dlaed6.o \ + dlaed7.o dlaed8.o dlaed9.o dlaeda.o dlaev2.o dlagtf.o \ + dlagts.o dlamrg.o dlanst.o \ + dlapy2.o dlapy3.o dlarnv.o \ + dlarra.o dlarrb.o dlarrc.o dlarrd.o dlarre.o dlarrf.o dlarrj.o \ + dlarrk.o dlarrr.o dlaneg.o \ + dlartg.o dlaruv.o dlas2.o dlascl.o \ + dlasd0.o dlasd1.o dlasd2.o dlasd3.o dlasd4.o dlasd5.o dlasd6.o \ + dlasd7.o dlasd8.o dlasda.o dlasdq.o dlasdt.o \ + dlaset.o dlasq1.o dlasq2.o dlasq3.o dlasq4.o dlasq5.o dlasq6.o \ + dlasr.o dlasrt.o dlassq.o dlasv2.o dpttrf.o dstebz.o dstedc.o \ + dsteqr.o dsterf.o dlaisnan.o disnan.o \ + dlartgp.o dlartgs.o \ + ../INSTALL/dlamch.o ../INSTALL/dsecnd_$(TIMER).o + +SLASRC = \ + sbdsvdx.o spotrf2.o sgetrf2.o \ + sgbbrd.o sgbcon.o sgbequ.o sgbrfs.o sgbsv.o \ + sgbsvx.o sgbtf2.o sgbtrf.o sgbtrs.o sgebak.o sgebal.o sgebd2.o \ + sgebrd.o sgecon.o sgeequ.o sgees.o sgeesx.o sgeev.o sgeevx.o \ + sgehd2.o sgehrd.o sgelq2.o sgelqf.o \ + sgels.o sgelsd.o sgelss.o sgelsy.o sgeql2.o sgeqlf.o \ + sgeqp3.o sgeqr2.o sgeqr2p.o sgeqrf.o sgeqrfp.o sgerfs.o \ + sgerq2.o sgerqf.o sgesc2.o sgesdd.o sgesv.o sgesvd.o sgesvdx.o sgesvx.o \ + sgetc2.o sgetf2.o sgetri.o \ + sggbak.o sggbal.o sgges.o sgges3.o sggesx.o \ + sggev.o sggev3.o sggevx.o \ + sggglm.o sgghrd.o sgghd3.o sgglse.o sggqrf.o \ + sggrqf.o sggsvd3.o sggsvp3.o sgtcon.o sgtrfs.o sgtsv.o \ + sgtsvx.o sgttrf.o sgttrs.o sgtts2.o shgeqz.o \ + shsein.o shseqr.o slabrd.o slacon.o slacn2.o \ + slaein.o slaexc.o slag2.o slags2.o slagtm.o slagv2.o slahqr.o \ + slahr2.o slaic1.o slaln2.o slals0.o slalsa.o slalsd.o \ + slangb.o slange.o slangt.o slanhs.o slansb.o slansp.o \ + slansy.o slantb.o slantp.o slantr.o slanv2.o \ + slapll.o slapmt.o \ + slaqgb.o slaqge.o slaqp2.o slaqps.o slaqsb.o slaqsp.o slaqsy.o \ + slaqr0.o slaqr1.o slaqr2.o slaqr3.o slaqr4.o slaqr5.o \ + slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \ + slarf.o slarfb.o slarfg.o slarfgp.o slarft.o slarfx.o slarfy.o slargv.o \ + slarrv.o slartv.o \ + slarz.o slarzb.o slarzt.o slaswp.o slasy2.o slasyf.o slasyf_rook.o \ + slasyf_rk.o \ + slatbs.o slatdf.o slatps.o slatrd.o slatrs.o slatrz.o \ + slauu2.o slauum.o sopgtr.o sopmtr.o sorg2l.o sorg2r.o \ + sorgbr.o sorghr.o sorgl2.o sorglq.o sorgql.o sorgqr.o sorgr2.o \ + sorgrq.o sorgtr.o sorm2l.o sorm2r.o sorm22.o \ + sormbr.o sormhr.o sorml2.o sormlq.o sormql.o sormqr.o sormr2.o \ + sormr3.o sormrq.o sormrz.o sormtr.o spbcon.o spbequ.o spbrfs.o \ + spbstf.o spbsv.o spbsvx.o \ + spbtf2.o spbtrf.o spbtrs.o spocon.o spoequ.o sporfs.o sposv.o \ + sposvx.o spotf2.o spotri.o spstrf.o spstf2.o \ + sppcon.o sppequ.o \ + spprfs.o sppsv.o sppsvx.o spptrf.o spptri.o spptrs.o sptcon.o \ + spteqr.o sptrfs.o sptsv.o sptsvx.o spttrs.o sptts2.o srscl.o \ + ssbev.o ssbevd.o ssbevx.o ssbgst.o ssbgv.o ssbgvd.o ssbgvx.o \ + ssbtrd.o sspcon.o sspev.o sspevd.o sspevx.o sspgst.o \ + sspgv.o sspgvd.o sspgvx.o ssprfs.o sspsv.o sspsvx.o ssptrd.o \ + ssptrf.o ssptri.o ssptrs.o sstegr.o sstein.o sstev.o sstevd.o sstevr.o \ + sstevx.o \ + ssycon.o ssyev.o ssyevd.o ssyevr.o ssyevx.o ssygs2.o \ + ssygst.o ssygv.o ssygvd.o ssygvx.o ssyrfs.o ssysv.o ssysvx.o \ + ssytd2.o ssytf2.o ssytrd.o ssytrf.o ssytri.o ssytri2.o ssytri2x.o \ + ssyswapr.o ssytrs.o ssytrs2.o ssyconv.o ssyconvf_rook.o \ + ssytf2_rook.o ssytrf_rook.o ssytrs_rook.o \ + ssytri_rook.o ssycon_rook.o ssysv_rook.o \ + ssytf2_rk.o ssytrf_rk.o ssytrs_3.o \ + ssytri_3.o ssytri_3x.o ssycon_3.o ssysv_rk.o \ + slasyf_aa.o ssysv_aa.o ssytrf_aa.o ssytrs_aa.o \ + stbcon.o \ + stbrfs.o stbtrs.o stgevc.o stgex2.o stgexc.o stgsen.o \ + stgsja.o stgsna.o stgsy2.o stgsyl.o stpcon.o stprfs.o stptri.o \ + stptrs.o \ + strcon.o strevc.o strevc3.o strexc.o strrfs.o strsen.o strsna.o strsyl.o \ + strti2.o strtri.o strtrs.o stzrzf.o sstemr.o \ + slansf.o spftrf.o spftri.o spftrs.o ssfrk.o stfsm.o stftri.o stfttp.o \ + stfttr.o stpttf.o stpttr.o strttf.o strttp.o \ + sgejsv.o sgesvj.o sgsvj0.o sgsvj1.o \ + sgeequb.o ssyequb.o spoequb.o sgbequb.o \ + sbbcsd.o slapmr.o sorbdb.o sorbdb1.o sorbdb2.o sorbdb3.o sorbdb4.o \ + sorbdb5.o sorbdb6.o sorcsd.o sorcsd2by1.o \ + sgeqrt.o sgeqrt2.o sgeqrt3.o sgemqrt.o \ + stpqrt.o stpqrt2.o stpmqrt.o stprfb.o \ + sgelqt.o sgelqt3.o sgemlqt.o \ + sgetsls.o sgeqr.o slatsqr.o slamtsqr.o sgemqr.o \ + sgelq.o slaswlq.o slamswlq.o sgemlq.o \ + stplqt.o stplqt2.o stpmlqt.o \ + ssytrd_2stage.o ssytrd_sy2sb.o ssytrd_sb2st.o ssb2st_kernels.o \ + ssyevd_2stage.o ssyev_2stage.o ssyevx_2stage.o ssyevr_2stage.o \ + ssbev_2stage.o ssbevx_2stage.o ssbevd_2stage.o ssygv_2stage.o + +DSLASRC = spotrs.o sgetrs.o spotrf.o sgetrf.o + +ifdef USEXBLAS +SXLASRC = sgesvxx.o sgerfsx.o sla_gerfsx_extended.o sla_geamv.o \ + sla_gercond.o sla_gerpvgrw.o ssysvxx.o ssyrfsx.o \ + sla_syrfsx_extended.o sla_syamv.o sla_syrcond.o sla_syrpvgrw.o \ + sposvxx.o sporfsx.o sla_porfsx_extended.o sla_porcond.o \ + sla_porpvgrw.o sgbsvxx.o sgbrfsx.o sla_gbrfsx_extended.o \ + sla_gbamv.o sla_gbrcond.o sla_gbrpvgrw.o sla_lin_berr.o slarscl2.o \ + slascl2.o sla_wwaddw.o +endif + +CLASRC = \ + cpotrf2.o cgetrf2.o \ + cbdsqr.o cgbbrd.o cgbcon.o cgbequ.o cgbrfs.o cgbsv.o cgbsvx.o \ + cgbtf2.o cgbtrf.o cgbtrs.o cgebak.o cgebal.o cgebd2.o cgebrd.o \ + cgecon.o cgeequ.o cgees.o cgeesx.o cgeev.o cgeevx.o \ + cgehd2.o cgehrd.o cgelq2.o cgelqf.o \ + cgels.o cgelsd.o cgelss.o cgelsy.o cgeql2.o cgeqlf.o cgeqp3.o \ + cgeqr2.o cgeqr2p.o cgeqrf.o cgeqrfp.o cgerfs.o \ + cgerq2.o cgerqf.o cgesc2.o cgesdd.o cgesv.o cgesvd.o cgesvdx.o \ + cgesvj.o cgejsv.o cgsvj0.o cgsvj1.o \ + cgesvx.o cgetc2.o cgetf2.o cgetri.o \ + cggbak.o cggbal.o cgges.o cgges3.o cggesx.o \ + cggev.o cggev3.o cggevx.o cggglm.o \ + cgghrd.o cgghd3.o cgglse.o cggqrf.o cggrqf.o \ + cggsvd3.o cggsvp3.o \ + cgtcon.o cgtrfs.o cgtsv.o cgtsvx.o cgttrf.o cgttrs.o cgtts2.o chbev.o \ + chbevd.o chbevx.o chbgst.o chbgv.o chbgvd.o chbgvx.o chbtrd.o \ + checon.o cheev.o cheevd.o cheevr.o cheevx.o chegs2.o chegst.o \ + chegv.o chegvd.o chegvx.o cherfs.o chesv.o chesvx.o chetd2.o \ + chetf2.o chetrd.o \ + chetrf.o chetri.o chetri2.o chetri2x.o cheswapr.o \ + chetrs.o chetrs2.o \ + chetf2_rook.o chetrf_rook.o chetri_rook.o \ + chetrs_rook.o checon_rook.o chesv_rook.o \ + chetf2_rk.o chetrf_rk.o chetri_3.o chetri_3x.o \ + chetrs_3.o checon_3.o chesv_rk.o \ + chesv_aa.o chetrf_aa.o chetrs_aa.o clahef_aa.o\ + chgeqz.o chpcon.o chpev.o chpevd.o \ + chpevx.o chpgst.o chpgv.o chpgvd.o chpgvx.o chprfs.o chpsv.o \ + chpsvx.o \ + chptrd.o chptrf.o chptri.o chptrs.o chsein.o chseqr.o clabrd.o \ + clacgv.o clacon.o clacn2.o clacp2.o clacpy.o clacrm.o clacrt.o cladiv.o \ + claed0.o claed7.o claed8.o \ + claein.o claesy.o claev2.o clags2.o clagtm.o \ + clahef.o clahef_rook.o clahef_rk.o clahqr.o \ + clahr2.o claic1.o clals0.o clalsa.o clalsd.o clangb.o clange.o clangt.o \ + clanhb.o clanhe.o \ + clanhp.o clanhs.o clanht.o clansb.o clansp.o clansy.o clantb.o \ + clantp.o clantr.o clapll.o clapmt.o clarcm.o claqgb.o claqge.o \ + claqhb.o claqhe.o claqhp.o claqp2.o claqps.o claqsb.o \ + claqr0.o claqr1.o claqr2.o claqr3.o claqr4.o claqr5.o \ + claqsp.o claqsy.o clar1v.o clar2v.o ilaclr.o ilaclc.o \ + clarf.o clarfb.o clarfg.o clarft.o clarfgp.o \ + clarfx.o clarfy.o clargv.o clarnv.o clarrv.o clartg.o clartv.o \ + clarz.o clarzb.o clarzt.o clascl.o claset.o clasr.o classq.o \ + claswp.o clasyf.o clasyf_rook.o clasyf_rk.o clasyf_aa.o \ + clatbs.o clatdf.o clatps.o clatrd.o clatrs.o clatrz.o \ + clauu2.o clauum.o cpbcon.o cpbequ.o cpbrfs.o cpbstf.o cpbsv.o \ + cpbsvx.o cpbtf2.o cpbtrf.o cpbtrs.o cpocon.o cpoequ.o cporfs.o \ + cposv.o cposvx.o cpotf2.o cpotri.o cpstrf.o cpstf2.o \ + cppcon.o cppequ.o cpprfs.o cppsv.o cppsvx.o cpptrf.o cpptri.o cpptrs.o \ + cptcon.o cpteqr.o cptrfs.o cptsv.o cptsvx.o cpttrf.o cpttrs.o cptts2.o \ + crot.o cspcon.o cspmv.o cspr.o csprfs.o cspsv.o \ + cspsvx.o csptrf.o csptri.o csptrs.o csrscl.o cstedc.o \ + cstegr.o cstein.o csteqr.o \ + csycon.o csymv.o \ + csyr.o csyrfs.o csysv.o csysvx.o csytf2.o csytrf.o csytri.o csytri2.o csytri2x.o \ + csyswapr.o csytrs.o csytrs2.o \ + csyconv.o csyconvf.o csyconvf_rook.o \ + csytf2_rook.o csytrf_rook.o csytrs_rook.o \ + csytri_rook.o csycon_rook.o csysv_rook.o \ + csytf2_rk.o csytrf_rk.o csytrf_aa.o csytrs_3.o csytrs_aa.o \ + csytri_3.o csytri_3x.o csycon_3.o csysv_rk.o csysv_aa.o \ + ctbcon.o ctbrfs.o ctbtrs.o ctgevc.o ctgex2.o \ + ctgexc.o ctgsen.o ctgsja.o ctgsna.o ctgsy2.o ctgsyl.o ctpcon.o \ + ctprfs.o ctptri.o \ + ctptrs.o ctrcon.o ctrevc.o ctrevc3.o ctrexc.o ctrrfs.o ctrsen.o ctrsna.o \ + ctrsyl.o ctrti2.o ctrtri.o ctrtrs.o ctzrzf.o cung2l.o cung2r.o \ + cungbr.o cunghr.o cungl2.o cunglq.o cungql.o cungqr.o cungr2.o \ + cungrq.o cungtr.o cunm2l.o cunm2r.o cunmbr.o cunmhr.o cunml2.o cunm22.o \ + cunmlq.o cunmql.o cunmqr.o cunmr2.o cunmr3.o cunmrq.o cunmrz.o \ + cunmtr.o cupgtr.o cupmtr.o icmax1.o scsum1.o cstemr.o \ + chfrk.o ctfttp.o clanhf.o cpftrf.o cpftri.o cpftrs.o ctfsm.o ctftri.o \ + ctfttr.o ctpttf.o ctpttr.o ctrttf.o ctrttp.o \ + cgeequb.o cgbequb.o csyequb.o cpoequb.o cheequb.o \ + cbbcsd.o clapmr.o cunbdb.o cunbdb1.o cunbdb2.o cunbdb3.o cunbdb4.o \ + cunbdb5.o cunbdb6.o cuncsd.o cuncsd2by1.o \ + cgeqrt.o cgeqrt2.o cgeqrt3.o cgemqrt.o \ + ctpqrt.o ctpqrt2.o ctpmqrt.o ctprfb.o \ + cgelqt.o cgelqt3.o cgemlqt.o \ + cgetsls.o cgeqr.o clatsqr.o clamtsqr.o cgemqr.o \ + cgelq.o claswlq.o clamswlq.o cgemlq.o \ + ctplqt.o ctplqt2.o ctpmlqt.o \ + chetrd_2stage.o chetrd_he2hb.o chetrd_hb2st.o chb2st_kernels.o \ + cheevd_2stage.o cheev_2stage.o cheevx_2stage.o cheevr_2stage.o \ + chbev_2stage.o chbevx_2stage.o chbevd_2stage.o chegv_2stage.o + +ifdef USEXBLAS +CXLASRC = cgesvxx.o cgerfsx.o cla_gerfsx_extended.o cla_geamv.o \ + cla_gercond_c.o cla_gercond_x.o cla_gerpvgrw.o \ + csysvxx.o csyrfsx.o cla_syrfsx_extended.o cla_syamv.o \ + cla_syrcond_c.o cla_syrcond_x.o cla_syrpvgrw.o \ + cposvxx.o cporfsx.o cla_porfsx_extended.o \ + cla_porcond_c.o cla_porcond_x.o cla_porpvgrw.o \ + cgbsvxx.o cgbrfsx.o cla_gbrfsx_extended.o cla_gbamv.o \ + cla_gbrcond_c.o cla_gbrcond_x.o cla_gbrpvgrw.o \ + chesvxx.o cherfsx.o cla_herfsx_extended.o cla_heamv.o \ + cla_hercond_c.o cla_hercond_x.o cla_herpvgrw.o \ + cla_lin_berr.o clarscl2.o clascl2.o cla_wwaddw.o +endif + +ZCLASRC = cpotrs.o cgetrs.o cpotrf.o cgetrf.o + +DLASRC = \ + dpotrf2.o dgetrf2.o \ + dbdsvdx.o \ + dgbbrd.o dgbcon.o dgbequ.o dgbrfs.o dgbsv.o \ + dgbsvx.o dgbtf2.o dgbtrf.o dgbtrs.o dgebak.o dgebal.o dgebd2.o \ + dgebrd.o dgecon.o dgeequ.o dgees.o dgeesx.o dgeev.o dgeevx.o \ + dgehd2.o dgehrd.o dgelq2.o dgelqf.o \ + dgels.o dgelsd.o dgelss.o dgelsy.o dgeql2.o dgeqlf.o \ + dgeqp3.o dgeqr2.o dgeqr2p.o dgeqrf.o dgeqrfp.o dgerfs.o \ + dgerq2.o dgerqf.o dgesc2.o dgesdd.o dgesv.o dgesvd.o dgesvdx.o dgesvx.o \ + dgetc2.o dgetf2.o dgetrf.o dgetri.o \ + dgetrs.o dggbak.o dggbal.o dgges.o dgges3.o dggesx.o \ + dggev.o dggev3.o dggevx.o \ + dggglm.o dgghrd.o dgghd3.o dgglse.o dggqrf.o \ + dggrqf.o dggsvd3.o dggsvp3.o dgtcon.o dgtrfs.o dgtsv.o \ + dgtsvx.o dgttrf.o dgttrs.o dgtts2.o dhgeqz.o \ + dhsein.o dhseqr.o dlabrd.o dlacon.o dlacn2.o \ + dlaein.o dlaexc.o dlag2.o dlags2.o dlagtm.o dlagv2.o dlahqr.o \ + dlahr2.o dlaic1.o dlaln2.o dlals0.o dlalsa.o dlalsd.o \ + dlangb.o dlange.o dlangt.o dlanhs.o dlansb.o dlansp.o \ + dlansy.o dlantb.o dlantp.o dlantr.o dlanv2.o \ + dlapll.o dlapmt.o \ + dlaqgb.o dlaqge.o dlaqp2.o dlaqps.o dlaqsb.o dlaqsp.o dlaqsy.o \ + dlaqr0.o dlaqr1.o dlaqr2.o dlaqr3.o dlaqr4.o dlaqr5.o \ + dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \ + dlarf.o dlarfb.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o \ + dlargv.o dlarrv.o dlartv.o \ + dlarz.o dlarzb.o dlarzt.o dlaswp.o dlasy2.o \ + dlasyf.o dlasyf_rook.o dlasyf_rk.o \ + dlatbs.o dlatdf.o dlatps.o dlatrd.o dlatrs.o dlatrz.o dlauu2.o \ + dlauum.o dopgtr.o dopmtr.o dorg2l.o dorg2r.o \ + dorgbr.o dorghr.o dorgl2.o dorglq.o dorgql.o dorgqr.o dorgr2.o \ + dorgrq.o dorgtr.o dorm2l.o dorm2r.o dorm22.o \ + dormbr.o dormhr.o dorml2.o dormlq.o dormql.o dormqr.o dormr2.o \ + dormr3.o dormrq.o dormrz.o dormtr.o dpbcon.o dpbequ.o dpbrfs.o \ + dpbstf.o dpbsv.o dpbsvx.o \ + dpbtf2.o dpbtrf.o dpbtrs.o dpocon.o dpoequ.o dporfs.o dposv.o \ + dposvx.o dpotf2.o dpotrf.o dpotri.o dpotrs.o dpstrf.o dpstf2.o \ + dppcon.o dppequ.o \ + dpprfs.o dppsv.o dppsvx.o dpptrf.o dpptri.o dpptrs.o dptcon.o \ + dpteqr.o dptrfs.o dptsv.o dptsvx.o dpttrs.o dptts2.o drscl.o \ + dsbev.o dsbevd.o dsbevx.o dsbgst.o dsbgv.o dsbgvd.o dsbgvx.o \ + dsbtrd.o dspcon.o dspev.o dspevd.o dspevx.o dspgst.o \ + dspgv.o dspgvd.o dspgvx.o dsprfs.o dspsv.o dspsvx.o dsptrd.o \ + dsptrf.o dsptri.o dsptrs.o dstegr.o dstein.o dstev.o dstevd.o dstevr.o \ + dstevx.o \ + dsycon.o dsyev.o dsyevd.o dsyevr.o \ + dsyevx.o dsygs2.o dsygst.o dsygv.o dsygvd.o dsygvx.o dsyrfs.o \ + dsysv.o dsysvx.o \ + dsytd2.o dsytf2.o dsytrd.o dsytrf.o dsytri.o dsytri2.o dsytri2x.o \ + dsyswapr.o dsytrs.o dsytrs2.o \ + dsyconv.o dsyconvf.o dsyconvf_rook.o \ + dsytf2_rook.o dsytrf_rook.o dsytrs_rook.o \ + dsytri_rook.o dsycon_rook.o dsysv_rook.o \ + dsytf2_rk.o dsytrf_rk.o dsytrs_3.o \ + dsytri_3.o dsytri_3x.o dsycon_3.o dsysv_rk.o \ + dlasyf_aa.o dsysv_aa.o dsytrf_aa.o dsytrs_aa.o \ + dtbcon.o dtbrfs.o dtbtrs.o dtgevc.o dtgex2.o dtgexc.o dtgsen.o \ + dtgsja.o dtgsna.o dtgsy2.o dtgsyl.o dtpcon.o dtprfs.o dtptri.o \ + dtptrs.o \ + dtrcon.o dtrevc.o dtrevc3.o dtrexc.o dtrrfs.o dtrsen.o dtrsna.o dtrsyl.o \ + dtrti2.o dtrtri.o dtrtrs.o dtzrzf.o dstemr.o \ + dsgesv.o dsposv.o dlag2s.o slag2d.o dlat2s.o \ + dlansf.o dpftrf.o dpftri.o dpftrs.o dsfrk.o dtfsm.o dtftri.o dtfttp.o \ + dtfttr.o dtpttf.o dtpttr.o dtrttf.o dtrttp.o \ + dgejsv.o dgesvj.o dgsvj0.o dgsvj1.o \ + dgeequb.o dsyequb.o dpoequb.o dgbequb.o \ + dbbcsd.o dlapmr.o dorbdb.o dorbdb1.o dorbdb2.o dorbdb3.o dorbdb4.o \ + dorbdb5.o dorbdb6.o dorcsd.o dorcsd2by1.o \ + dgeqrt.o dgeqrt2.o dgeqrt3.o dgemqrt.o \ + dtpqrt.o dtpqrt2.o dtpmqrt.o dtprfb.o \ + dgelqt.o dgelqt3.o dgemlqt.o \ + dgetsls.o dgeqr.o dlatsqr.o dlamtsqr.o dgemqr.o \ + dgelq.o dlaswlq.o dlamswlq.o dgemlq.o \ + dtplqt.o dtplqt2.o dtpmlqt.o \ + dsytrd_2stage.o dsytrd_sy2sb.o dsytrd_sb2st.o dsb2st_kernels.o \ + dsyevd_2stage.o dsyev_2stage.o dsyevx_2stage.o dsyevr_2stage.o \ + dsbev_2stage.o dsbevx_2stage.o dsbevd_2stage.o dsygv_2stage.o + +ifdef USEXBLAS +DXLASRC = dgesvxx.o dgerfsx.o dla_gerfsx_extended.o dla_geamv.o \ + dla_gercond.o dla_gerpvgrw.o dsysvxx.o dsyrfsx.o \ + dla_syrfsx_extended.o dla_syamv.o dla_syrcond.o dla_syrpvgrw.o \ + dposvxx.o dporfsx.o dla_porfsx_extended.o dla_porcond.o \ + dla_porpvgrw.o dgbsvxx.o dgbrfsx.o dla_gbrfsx_extended.o \ + dla_gbamv.o dla_gbrcond.o dla_gbrpvgrw.o dla_lin_berr.o dlarscl2.o \ + dlascl2.o dla_wwaddw.o +endif + +ZLASRC = \ + zpotrf2.o zgetrf2.o \ + zbdsqr.o zgbbrd.o zgbcon.o zgbequ.o zgbrfs.o zgbsv.o zgbsvx.o \ + zgbtf2.o zgbtrf.o zgbtrs.o zgebak.o zgebal.o zgebd2.o zgebrd.o \ + zgecon.o zgeequ.o zgees.o zgeesx.o zgeev.o zgeevx.o \ + zgehd2.o zgehrd.o zgelq2.o zgelqf.o \ + zgels.o zgelsd.o zgelss.o zgelsy.o zgeql2.o zgeqlf.o zgeqp3.o \ + zgeqr2.o zgeqr2p.o zgeqrf.o zgeqrfp.o zgerfs.o zgerq2.o zgerqf.o \ + zgesc2.o zgesdd.o zgesv.o zgesvd.o zgesvdx.o \ + zgesvj.o zgejsv.o zgsvj0.o zgsvj1.o \ + zgesvx.o zgetc2.o zgetf2.o zgetrf.o \ + zgetri.o zgetrs.o \ + zggbak.o zggbal.o zgges.o zgges3.o zggesx.o \ + zggev.o zggev3.o zggevx.o zggglm.o \ + zgghrd.o zgghd3.o zgglse.o zggqrf.o zggrqf.o \ + zggsvd3.o zggsvp3.o \ + zgtcon.o zgtrfs.o zgtsv.o zgtsvx.o zgttrf.o zgttrs.o zgtts2.o zhbev.o \ + zhbevd.o zhbevx.o zhbgst.o zhbgv.o zhbgvd.o zhbgvx.o zhbtrd.o \ + zhecon.o zheev.o zheevd.o zheevr.o zheevx.o zhegs2.o zhegst.o \ + zhegv.o zhegvd.o zhegvx.o zherfs.o zhesv.o zhesvx.o zhetd2.o \ + zhetf2.o zhetrd.o \ + zhetrf.o zhetri.o zhetri2.o zhetri2x.o zheswapr.o \ + zhetrs.o zhetrs2.o \ + zhetf2_rook.o zhetrf_rook.o zhetri_rook.o \ + zhetrs_rook.o zhecon_rook.o zhesv_rook.o \ + zhetf2_rk.o zhetrf_rk.o zhetri_3.o zhetri_3x.o \ + zhetrs_3.o zhecon_3.o zhesv_rk.o \ + zhesv_aa.o zhetrf_aa.o zhetrs_aa.o zlahef_aa.o \ + zhgeqz.o zhpcon.o zhpev.o zhpevd.o \ + zhpevx.o zhpgst.o zhpgv.o zhpgvd.o zhpgvx.o zhprfs.o zhpsv.o \ + zhpsvx.o \ + zhptrd.o zhptrf.o zhptri.o zhptrs.o zhsein.o zhseqr.o zlabrd.o \ + zlacgv.o zlacon.o zlacn2.o zlacp2.o zlacpy.o zlacrm.o zlacrt.o zladiv.o \ + zlaed0.o zlaed7.o zlaed8.o \ + zlaein.o zlaesy.o zlaev2.o zlags2.o zlagtm.o \ + zlahef.o zlahef_rook.o zlahef_rk.o zlahqr.o \ + zlahr2.o zlaic1.o zlals0.o zlalsa.o zlalsd.o zlangb.o zlange.o \ + zlangt.o zlanhb.o \ + zlanhe.o \ + zlanhp.o zlanhs.o zlanht.o zlansb.o zlansp.o zlansy.o zlantb.o \ + zlantp.o zlantr.o zlapll.o zlapmt.o zlaqgb.o zlaqge.o \ + zlaqhb.o zlaqhe.o zlaqhp.o zlaqp2.o zlaqps.o zlaqsb.o \ + zlaqr0.o zlaqr1.o zlaqr2.o zlaqr3.o zlaqr4.o zlaqr5.o \ + zlaqsp.o zlaqsy.o zlar1v.o zlar2v.o ilazlr.o ilazlc.o \ + zlarcm.o zlarf.o zlarfb.o \ + zlarfg.o zlarft.o zlarfgp.o \ + zlarfx.o zlarfy.o zlargv.o zlarnv.o zlarrv.o zlartg.o zlartv.o \ + zlarz.o zlarzb.o zlarzt.o zlascl.o zlaset.o zlasr.o \ + zlassq.o zlaswp.o zlasyf.o zlasyf_rook.o zlasyf_rk.o zlasyf_aa.o \ + zlatbs.o zlatdf.o zlatps.o zlatrd.o zlatrs.o zlatrz.o zlauu2.o \ + zlauum.o zpbcon.o zpbequ.o zpbrfs.o zpbstf.o zpbsv.o \ + zpbsvx.o zpbtf2.o zpbtrf.o zpbtrs.o zpocon.o zpoequ.o zporfs.o \ + zposv.o zposvx.o zpotf2.o zpotrf.o zpotri.o zpotrs.o zpstrf.o zpstf2.o \ + zppcon.o zppequ.o zpprfs.o zppsv.o zppsvx.o zpptrf.o zpptri.o zpptrs.o \ + zptcon.o zpteqr.o zptrfs.o zptsv.o zptsvx.o zpttrf.o zpttrs.o zptts2.o \ + zrot.o zspcon.o zspmv.o zspr.o zsprfs.o zspsv.o \ + zspsvx.o zsptrf.o zsptri.o zsptrs.o zdrscl.o zstedc.o \ + zstegr.o zstein.o zsteqr.o \ + zsycon.o zsymv.o \ + zsyr.o zsyrfs.o zsysv.o zsysvx.o zsytf2.o zsytrf.o zsytri.o zsytri2.o zsytri2x.o \ + zsyswapr.o zsytrs.o zsytrs2.o \ + zsyconv.o zsyconvf.o zsyconvf_rook.o \ + zsytf2_rook.o zsytrf_rook.o zsytrs_rook.o zsytrs_aa.o \ + zsytri_rook.o zsycon_rook.o zsysv_rook.o \ + zsytf2_rk.o zsytrf_rk.o zsytrf_aa.o zsytrs_3.o \ + zsytri_3.o zsytri_3x.o zsycon_3.o zsysv_rk.o zsysv_aa.o \ + ztbcon.o ztbrfs.o ztbtrs.o ztgevc.o ztgex2.o \ + ztgexc.o ztgsen.o ztgsja.o ztgsna.o ztgsy2.o ztgsyl.o ztpcon.o \ + ztprfs.o ztptri.o \ + ztptrs.o ztrcon.o ztrevc.o ztrevc3.o ztrexc.o ztrrfs.o ztrsen.o ztrsna.o \ + ztrsyl.o ztrti2.o ztrtri.o ztrtrs.o ztzrzf.o zung2l.o \ + zung2r.o zungbr.o zunghr.o zungl2.o zunglq.o zungql.o zungqr.o zungr2.o \ + zungrq.o zungtr.o zunm2l.o zunm2r.o zunmbr.o zunmhr.o zunml2.o zunm22.o \ + zunmlq.o zunmql.o zunmqr.o zunmr2.o zunmr3.o zunmrq.o zunmrz.o \ + zunmtr.o zupgtr.o \ + zupmtr.o izmax1.o dzsum1.o zstemr.o \ + zcgesv.o zcposv.o zlag2c.o clag2z.o zlat2c.o \ + zhfrk.o ztfttp.o zlanhf.o zpftrf.o zpftri.o zpftrs.o ztfsm.o ztftri.o \ + ztfttr.o ztpttf.o ztpttr.o ztrttf.o ztrttp.o \ + zgeequb.o zgbequb.o zsyequb.o zpoequb.o zheequb.o \ + zbbcsd.o zlapmr.o zunbdb.o zunbdb1.o zunbdb2.o zunbdb3.o zunbdb4.o \ + zunbdb5.o zunbdb6.o zuncsd.o zuncsd2by1.o \ + zgeqrt.o zgeqrt2.o zgeqrt3.o zgemqrt.o \ + ztpqrt.o ztpqrt2.o ztpmqrt.o ztprfb.o \ + ztplqt.o ztplqt2.o ztpmlqt.o \ + zgelqt.o zgelqt3.o zgemlqt.o \ + zgetsls.o zgeqr.o zlatsqr.o zlamtsqr.o zgemqr.o \ + zgelq.o zlaswlq.o zlamswlq.o zgemlq.o \ + ztplqt.o ztplqt2.o ztpmlqt.o \ + zhetrd_2stage.o zhetrd_he2hb.o zhetrd_hb2st.o zhb2st_kernels.o \ + zheevd_2stage.o zheev_2stage.o zheevx_2stage.o zheevr_2stage.o \ + zhbev_2stage.o zhbevx_2stage.o zhbevd_2stage.o zhegv_2stage.o + +ifdef USEXBLAS +ZXLASRC = zgesvxx.o zgerfsx.o zla_gerfsx_extended.o zla_geamv.o \ + zla_gercond_c.o zla_gercond_x.o zla_gerpvgrw.o zsysvxx.o zsyrfsx.o \ + zla_syrfsx_extended.o zla_syamv.o zla_syrcond_c.o zla_syrcond_x.o \ + zla_syrpvgrw.o zposvxx.o zporfsx.o zla_porfsx_extended.o \ + zla_porcond_c.o zla_porcond_x.o zla_porpvgrw.o zgbsvxx.o zgbrfsx.o \ + zla_gbrfsx_extended.o zla_gbamv.o zla_gbrcond_c.o zla_gbrcond_x.o \ + zla_gbrpvgrw.o zhesvxx.o zherfsx.o zla_herfsx_extended.o \ + zla_heamv.o zla_hercond_c.o zla_hercond_x.o zla_herpvgrw.o \ + zla_lin_berr.o zlarscl2.o zlascl2.o zla_wwaddw.o +endif + +DEPRECSRC = DEPRECATED/cgegs.o DEPRECATED/cgegv.o DEPRECATED/cgelsx.o \ + DEPRECATED/cgeqpf.o DEPRECATED/cggsvd.o DEPRECATED/cggsvp.o \ + DEPRECATED/clahrd.o DEPRECATED/clatzm.o DEPRECATED/ctzrqf.o \ + DEPRECATED/dgegs.o DEPRECATED/dgegv.o DEPRECATED/dgelsx.o \ + DEPRECATED/dgeqpf.o DEPRECATED/dggsvd.o DEPRECATED/dggsvp.o \ + DEPRECATED/dlahrd.o DEPRECATED/dlatzm.o DEPRECATED/dtzrqf.o \ + DEPRECATED/sgegs.o DEPRECATED/sgegv.o DEPRECATED/sgelsx.o \ + DEPRECATED/sgeqpf.o DEPRECATED/sggsvd.o DEPRECATED/sggsvp.o \ + DEPRECATED/slahrd.o DEPRECATED/slatzm.o DEPRECATED/stzrqf.o \ + DEPRECATED/zgegs.o DEPRECATED/zgegv.o DEPRECATED/zgelsx.o \ + DEPRECATED/zgeqpf.o DEPRECATED/zggsvd.o DEPRECATED/zggsvp.o \ + DEPRECATED/zlahrd.o DEPRECATED/zlatzm.o DEPRECATED/ztzrqf.o + +ALLOBJ = $(SLASRC) $(DLASRC) $(DSLASRC) $(CLASRC) $(ZLASRC) $(ZCLASRC) \ + $(SCLAUX) $(DZLAUX) $(ALLAUX) + +ifdef USEXBLAS +ALLXOBJ = $(SXLASRC) $(DXLASRC) $(CXLASRC) $(ZXLASRC) +endif + +ifdef BUILD_DEPRECATED +DEPRECATED = $(DEPRECSRC) +endif + +all: ../$(LAPACKLIB) + +../$(LAPACKLIB): $(ALLOBJ) $(ALLXOBJ) $(DEPRECATED) + $(ARCH) $(ARCHFLAGS) $@ $(ALLOBJ) $(ALLXOBJ) $(DEPRECATED) + $(RANLIB) $@ + +single: $(SLASRC) $(DSLASRC) $(SXLASRC) $(SCLAUX) $(ALLAUX) + $(ARCH) $(ARCHFLAGS) ../$(LAPACKLIB) $(SLASRC) $(DSLASRC) \ + $(SXLASRC) $(SCLAUX) $(ALLAUX) + $(RANLIB) ../$(LAPACKLIB) + +complex: $(CLASRC) $(ZCLASRC) $(CXLASRC) $(SCLAUX) $(ALLAUX) + $(ARCH) $(ARCHFLAGS) ../$(LAPACKLIB) $(CLASRC) $(ZCLASRC) \ + $(CXLASRC) $(SCLAUX) $(ALLAUX) + $(RANLIB) ../$(LAPACKLIB) + +double: $(DLASRC) $(DSLASRC) $(DXLASRC) $(DZLAUX) $(ALLAUX) + $(ARCH) $(ARCHFLAGS) ../$(LAPACKLIB) $(DLASRC) $(DSLASRC) \ + $(DXLASRC) $(DZLAUX) $(ALLAUX) + $(RANLIB) ../$(LAPACKLIB) + +complex16: $(ZLASRC) $(ZCLASRC) $(ZXLASRC) $(DZLAUX) $(ALLAUX) + $(ARCH) $(ARCHFLAGS) ../$(LAPACKLIB) $(ZLASRC) $(ZCLASRC) \ + $(ZXLASRC) $(DZLAUX) $(ALLAUX) + $(RANLIB) ../$(LAPACKLIB) + +$(ALLAUX): $(FRC) +$(SCLAUX): $(FRC) +$(DZLAUX): $(FRC) +$(SLASRC): $(FRC) +$(CLASRC): $(FRC) +$(DLASRC): $(FRC) +$(ZLASRC): $(FRC) +$(ZCLASRC): $(FRC) +$(DSLASRC): $(FRC) +ifdef USEXBLAS +$(SXLASRC): $(FRC) +$(CXLASRC): $(FRC) +$(DXLASRC): $(FRC) +$(ZXLASRC): $(FRC) +endif + +FRC: + @FRC=$(FRC) + +clean: + rm -f *.o DEPRECATED/*.o + +.f.o: + $(FORTRAN) $(OPTS) -c -o $@ $< + +.F.o: + $(FORTRAN) $(OPTS) -c $< -o $@ + +slaruv.o: slaruv.f ; $(FORTRAN) $(NOOPT) -c -o $@ $< +dlaruv.o: dlaruv.f ; $(FORTRAN) $(NOOPT) -c -o $@ $< +sla_wwaddw.o: sla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c -o $@ $< +dla_wwaddw.o: dla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c -o $@ $< +cla_wwaddw.o: cla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c -o $@ $< +zla_wwaddw.o: zla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c -o $@ $< diff --git a/math/lapack/src/main/fortran/dbbcsd.f b/math/lapack/src/main/fortran/dbbcsd.f new file mode 100644 index 0000000000..d7c7d14a78 --- /dev/null +++ b/math/lapack/src/main/fortran/dbbcsd.f @@ -0,0 +1,1080 @@ +*> \brief \b DBBCSD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DBBCSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, +* THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, +* V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, +* B22D, B22E, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS +* INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q +* .. +* .. Array Arguments .. +* DOUBLE PRECISION B11D( * ), B11E( * ), B12D( * ), B12E( * ), +* $ B21D( * ), B21E( * ), B22D( * ), B22E( * ), +* $ PHI( * ), THETA( * ), WORK( * ) +* DOUBLE PRECISION U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), +* $ V2T( LDV2T, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DBBCSD computes the CS decomposition of an orthogonal matrix in +*> bidiagonal-block form, +*> +*> +*> [ B11 | B12 0 0 ] +*> [ 0 | 0 -I 0 ] +*> X = [----------------] +*> [ B21 | B22 0 0 ] +*> [ 0 | 0 0 I ] +*> +*> [ C | -S 0 0 ] +*> [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**T +*> = [---------] [---------------] [---------] . +*> [ | U2 ] [ S | C 0 0 ] [ | V2 ] +*> [ 0 | 0 0 I ] +*> +*> X is M-by-M, its top-left block is P-by-Q, and Q must be no larger +*> than P, M-P, or M-Q. (If Q is not the smallest index, then X must be +*> transposed and/or permuted. This can be done in constant time using +*> the TRANS and SIGNS options. See DORCSD for details.) +*> +*> The bidiagonal matrices B11, B12, B21, and B22 are represented +*> implicitly by angles THETA(1:Q) and PHI(1:Q-1). +*> +*> The orthogonal matrices U1, U2, V1T, and V2T are input/output. +*> The input matrices are pre- or post-multiplied by the appropriate +*> singular vector matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBU1 +*> \verbatim +*> JOBU1 is CHARACTER +*> = 'Y': U1 is updated; +*> otherwise: U1 is not updated. +*> \endverbatim +*> +*> \param[in] JOBU2 +*> \verbatim +*> JOBU2 is CHARACTER +*> = 'Y': U2 is updated; +*> otherwise: U2 is not updated. +*> \endverbatim +*> +*> \param[in] JOBV1T +*> \verbatim +*> JOBV1T is CHARACTER +*> = 'Y': V1T is updated; +*> otherwise: V1T is not updated. +*> \endverbatim +*> +*> \param[in] JOBV2T +*> \verbatim +*> JOBV2T is CHARACTER +*> = 'Y': V2T is updated; +*> otherwise: V2T is not updated. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER +*> = 'T': X, U1, U2, V1T, and V2T are stored in row-major +*> order; +*> otherwise: X, U1, U2, V1T, and V2T are stored in column- +*> major order. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows and columns in X, the orthogonal matrix in +*> bidiagonal-block form. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in the top-left block of X. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in the top-left block of X. +*> 0 <= Q <= MIN(P,M-P,M-Q). +*> \endverbatim +*> +*> \param[in,out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> On entry, the angles THETA(1),...,THETA(Q) that, along with +*> PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block +*> form. On exit, the angles whose cosines and sines define the +*> diagonal blocks in the CS decomposition. +*> \endverbatim +*> +*> \param[in,out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),..., +*> THETA(Q), define the matrix in bidiagonal-block form. +*> \endverbatim +*> +*> \param[in,out] U1 +*> \verbatim +*> U1 is DOUBLE PRECISION array, dimension (LDU1,P) +*> On entry, a P-by-P matrix. On exit, U1 is postmultiplied +*> by the left singular vector matrix common to [ B11 ; 0 ] and +*> [ B12 0 0 ; 0 -I 0 0 ]. +*> \endverbatim +*> +*> \param[in] LDU1 +*> \verbatim +*> LDU1 is INTEGER +*> The leading dimension of the array U1, LDU1 >= MAX(1,P). +*> \endverbatim +*> +*> \param[in,out] U2 +*> \verbatim +*> U2 is DOUBLE PRECISION array, dimension (LDU2,M-P) +*> On entry, an (M-P)-by-(M-P) matrix. On exit, U2 is +*> postmultiplied by the left singular vector matrix common to +*> [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ]. +*> \endverbatim +*> +*> \param[in] LDU2 +*> \verbatim +*> LDU2 is INTEGER +*> The leading dimension of the array U2, LDU2 >= MAX(1,M-P). +*> \endverbatim +*> +*> \param[in,out] V1T +*> \verbatim +*> V1T is DOUBLE PRECISION array, dimension (LDV1T,Q) +*> On entry, a Q-by-Q matrix. On exit, V1T is premultiplied +*> by the transpose of the right singular vector +*> matrix common to [ B11 ; 0 ] and [ B21 ; 0 ]. +*> \endverbatim +*> +*> \param[in] LDV1T +*> \verbatim +*> LDV1T is INTEGER +*> The leading dimension of the array V1T, LDV1T >= MAX(1,Q). +*> \endverbatim +*> +*> \param[in,out] V2T +*> \verbatim +*> V2T is DOUBLE PRECISION array, dimenison (LDV2T,M-Q) +*> On entry, an (M-Q)-by-(M-Q) matrix. On exit, V2T is +*> premultiplied by the transpose of the right +*> singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and +*> [ B22 0 0 ; 0 0 I ]. +*> \endverbatim +*> +*> \param[in] LDV2T +*> \verbatim +*> LDV2T is INTEGER +*> The leading dimension of the array V2T, LDV2T >= MAX(1,M-Q). +*> \endverbatim +*> +*> \param[out] B11D +*> \verbatim +*> B11D is DOUBLE PRECISION array, dimension (Q) +*> When DBBCSD converges, B11D contains the cosines of THETA(1), +*> ..., THETA(Q). If DBBCSD fails to converge, then B11D +*> contains the diagonal of the partially reduced top-left +*> block. +*> \endverbatim +*> +*> \param[out] B11E +*> \verbatim +*> B11E is DOUBLE PRECISION array, dimension (Q-1) +*> When DBBCSD converges, B11E contains zeros. If DBBCSD fails +*> to converge, then B11E contains the superdiagonal of the +*> partially reduced top-left block. +*> \endverbatim +*> +*> \param[out] B12D +*> \verbatim +*> B12D is DOUBLE PRECISION array, dimension (Q) +*> When DBBCSD converges, B12D contains the negative sines of +*> THETA(1), ..., THETA(Q). If DBBCSD fails to converge, then +*> B12D contains the diagonal of the partially reduced top-right +*> block. +*> \endverbatim +*> +*> \param[out] B12E +*> \verbatim +*> B12E is DOUBLE PRECISION array, dimension (Q-1) +*> When DBBCSD converges, B12E contains zeros. If DBBCSD fails +*> to converge, then B12E contains the subdiagonal of the +*> partially reduced top-right block. +*> \endverbatim +*> +*> \param[out] B21D +*> \verbatim +*> B21D is DOUBLE PRECISION array, dimension (Q) +*> When DBBCSD converges, B21D contains the negative sines of +*> THETA(1), ..., THETA(Q). If DBBCSD fails to converge, then +*> B21D contains the diagonal of the partially reduced bottom-left +*> block. +*> \endverbatim +*> +*> \param[out] B21E +*> \verbatim +*> B21E is DOUBLE PRECISION array, dimension (Q-1) +*> When DBBCSD converges, B21E contains zeros. If DBBCSD fails +*> to converge, then B21E contains the subdiagonal of the +*> partially reduced bottom-left block. +*> \endverbatim +*> +*> \param[out] B22D +*> \verbatim +*> B22D is DOUBLE PRECISION array, dimension (Q) +*> When DBBCSD converges, B22D contains the negative sines of +*> THETA(1), ..., THETA(Q). If DBBCSD fails to converge, then +*> B22D contains the diagonal of the partially reduced bottom-right +*> block. +*> \endverbatim +*> +*> \param[out] B22E +*> \verbatim +*> B22E is DOUBLE PRECISION array, dimension (Q-1) +*> When DBBCSD converges, B22E contains zeros. If DBBCSD fails +*> to converge, then B22E contains the subdiagonal of the +*> partially reduced bottom-right block. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= MAX(1,8*Q). +*> +*> If LWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal size of the WORK array, +*> returns this value as the first entry of the work array, and +*> no error message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if DBBCSD did not converge, INFO specifies the number +*> of nonzero entries in PHI, and B11D, B11E, etc., +*> contain the partially reduced matrix. +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> TOLMUL DOUBLE PRECISION, default = MAX(10,MIN(100,EPS**(-1/8))) +*> TOLMUL controls the convergence criterion of the QR loop. +*> Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they +*> are within TOLMUL*EPS of either bound. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, + $ THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, + $ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, + $ B22D, B22E, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS + INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q +* .. +* .. Array Arguments .. + DOUBLE PRECISION B11D( * ), B11E( * ), B12D( * ), B12E( * ), + $ B21D( * ), B21E( * ), B22D( * ), B22E( * ), + $ PHI( * ), THETA( * ), WORK( * ) + DOUBLE PRECISION U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), + $ V2T( LDV2T, * ) +* .. +* +* =================================================================== +* +* .. Parameters .. + INTEGER MAXITR + PARAMETER ( MAXITR = 6 ) + DOUBLE PRECISION HUNDRED, MEIGHTH, ONE, PIOVER2, TEN, ZERO + PARAMETER ( HUNDRED = 100.0D0, MEIGHTH = -0.125D0, + $ ONE = 1.0D0, PIOVER2 = 1.57079632679489662D0, + $ TEN = 10.0D0, ZERO = 0.0D0 ) + DOUBLE PRECISION NEGONE + PARAMETER ( NEGONE = -1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL COLMAJOR, LQUERY, RESTART11, RESTART12, + $ RESTART21, RESTART22, WANTU1, WANTU2, WANTV1T, + $ WANTV2T + INTEGER I, IMIN, IMAX, ITER, IU1CS, IU1SN, IU2CS, + $ IU2SN, IV1TCS, IV1TSN, IV2TCS, IV2TSN, J, + $ LWORKMIN, LWORKOPT, MAXIT, MINI + DOUBLE PRECISION B11BULGE, B12BULGE, B21BULGE, B22BULGE, DUMMY, + $ EPS, MU, NU, R, SIGMA11, SIGMA21, + $ TEMP, THETAMAX, THETAMIN, THRESH, TOL, TOLMUL, + $ UNFL, X1, X2, Y1, Y2 +* +* .. External Subroutines .. + EXTERNAL DLASR, DSCAL, DSWAP, DLARTGP, DLARTGS, DLAS2, + $ XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME + EXTERNAL LSAME, DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, ATAN2, COS, MAX, MIN, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 + WANTU1 = LSAME( JOBU1, 'Y' ) + WANTU2 = LSAME( JOBU2, 'Y' ) + WANTV1T = LSAME( JOBV1T, 'Y' ) + WANTV2T = LSAME( JOBV2T, 'Y' ) + COLMAJOR = .NOT. LSAME( TRANS, 'T' ) +* + IF( M .LT. 0 ) THEN + INFO = -6 + ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN + INFO = -7 + ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN + INFO = -8 + ELSE IF( Q .GT. P .OR. Q .GT. M-P .OR. Q .GT. M-Q ) THEN + INFO = -8 + ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN + INFO = -12 + ELSE IF( WANTU2 .AND. LDU2 .LT. M-P ) THEN + INFO = -14 + ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN + INFO = -16 + ELSE IF( WANTV2T .AND. LDV2T .LT. M-Q ) THEN + INFO = -18 + END IF +* +* Quick return if Q = 0 +* + IF( INFO .EQ. 0 .AND. Q .EQ. 0 ) THEN + LWORKMIN = 1 + WORK(1) = LWORKMIN + RETURN + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + IU1CS = 1 + IU1SN = IU1CS + Q + IU2CS = IU1SN + Q + IU2SN = IU2CS + Q + IV1TCS = IU2SN + Q + IV1TSN = IV1TCS + Q + IV2TCS = IV1TSN + Q + IV2TSN = IV2TCS + Q + LWORKOPT = IV2TSN + Q - 1 + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT. LQUERY ) THEN + INFO = -28 + END IF + END IF +* + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DBBCSD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Get machine constants +* + EPS = DLAMCH( 'Epsilon' ) + UNFL = DLAMCH( 'Safe minimum' ) + TOLMUL = MAX( TEN, MIN( HUNDRED, EPS**MEIGHTH ) ) + TOL = TOLMUL*EPS + THRESH = MAX( TOL, MAXITR*Q*Q*UNFL ) +* +* Test for negligible sines or cosines +* + DO I = 1, Q + IF( THETA(I) .LT. THRESH ) THEN + THETA(I) = ZERO + ELSE IF( THETA(I) .GT. PIOVER2-THRESH ) THEN + THETA(I) = PIOVER2 + END IF + END DO + DO I = 1, Q-1 + IF( PHI(I) .LT. THRESH ) THEN + PHI(I) = ZERO + ELSE IF( PHI(I) .GT. PIOVER2-THRESH ) THEN + PHI(I) = PIOVER2 + END IF + END DO +* +* Initial deflation +* + IMAX = Q + DO WHILE( IMAX .GT. 1 ) + IF( PHI(IMAX-1) .NE. ZERO ) THEN + EXIT + END IF + IMAX = IMAX - 1 + END DO + IMIN = IMAX - 1 + IF ( IMIN .GT. 1 ) THEN + DO WHILE( PHI(IMIN-1) .NE. ZERO ) + IMIN = IMIN - 1 + IF ( IMIN .LE. 1 ) EXIT + END DO + END IF +* +* Initialize iteration counter +* + MAXIT = MAXITR*Q*Q + ITER = 0 +* +* Begin main iteration loop +* + DO WHILE( IMAX .GT. 1 ) +* +* Compute the matrix entries +* + B11D(IMIN) = COS( THETA(IMIN) ) + B21D(IMIN) = -SIN( THETA(IMIN) ) + DO I = IMIN, IMAX - 1 + B11E(I) = -SIN( THETA(I) ) * SIN( PHI(I) ) + B11D(I+1) = COS( THETA(I+1) ) * COS( PHI(I) ) + B12D(I) = SIN( THETA(I) ) * COS( PHI(I) ) + B12E(I) = COS( THETA(I+1) ) * SIN( PHI(I) ) + B21E(I) = -COS( THETA(I) ) * SIN( PHI(I) ) + B21D(I+1) = -SIN( THETA(I+1) ) * COS( PHI(I) ) + B22D(I) = COS( THETA(I) ) * COS( PHI(I) ) + B22E(I) = -SIN( THETA(I+1) ) * SIN( PHI(I) ) + END DO + B12D(IMAX) = SIN( THETA(IMAX) ) + B22D(IMAX) = COS( THETA(IMAX) ) +* +* Abort if not converging; otherwise, increment ITER +* + IF( ITER .GT. MAXIT ) THEN + INFO = 0 + DO I = 1, Q + IF( PHI(I) .NE. ZERO ) + $ INFO = INFO + 1 + END DO + RETURN + END IF +* + ITER = ITER + IMAX - IMIN +* +* Compute shifts +* + THETAMAX = THETA(IMIN) + THETAMIN = THETA(IMIN) + DO I = IMIN+1, IMAX + IF( THETA(I) > THETAMAX ) + $ THETAMAX = THETA(I) + IF( THETA(I) < THETAMIN ) + $ THETAMIN = THETA(I) + END DO +* + IF( THETAMAX .GT. PIOVER2 - THRESH ) THEN +* +* Zero on diagonals of B11 and B22; induce deflation with a +* zero shift +* + MU = ZERO + NU = ONE +* + ELSE IF( THETAMIN .LT. THRESH ) THEN +* +* Zero on diagonals of B12 and B22; induce deflation with a +* zero shift +* + MU = ONE + NU = ZERO +* + ELSE +* +* Compute shifts for B11 and B21 and use the lesser +* + CALL DLAS2( B11D(IMAX-1), B11E(IMAX-1), B11D(IMAX), SIGMA11, + $ DUMMY ) + CALL DLAS2( B21D(IMAX-1), B21E(IMAX-1), B21D(IMAX), SIGMA21, + $ DUMMY ) +* + IF( SIGMA11 .LE. SIGMA21 ) THEN + MU = SIGMA11 + NU = SQRT( ONE - MU**2 ) + IF( MU .LT. THRESH ) THEN + MU = ZERO + NU = ONE + END IF + ELSE + NU = SIGMA21 + MU = SQRT( 1.0 - NU**2 ) + IF( NU .LT. THRESH ) THEN + MU = ONE + NU = ZERO + END IF + END IF + END IF +* +* Rotate to produce bulges in B11 and B21 +* + IF( MU .LE. NU ) THEN + CALL DLARTGS( B11D(IMIN), B11E(IMIN), MU, + $ WORK(IV1TCS+IMIN-1), WORK(IV1TSN+IMIN-1) ) + ELSE + CALL DLARTGS( B21D(IMIN), B21E(IMIN), NU, + $ WORK(IV1TCS+IMIN-1), WORK(IV1TSN+IMIN-1) ) + END IF +* + TEMP = WORK(IV1TCS+IMIN-1)*B11D(IMIN) + + $ WORK(IV1TSN+IMIN-1)*B11E(IMIN) + B11E(IMIN) = WORK(IV1TCS+IMIN-1)*B11E(IMIN) - + $ WORK(IV1TSN+IMIN-1)*B11D(IMIN) + B11D(IMIN) = TEMP + B11BULGE = WORK(IV1TSN+IMIN-1)*B11D(IMIN+1) + B11D(IMIN+1) = WORK(IV1TCS+IMIN-1)*B11D(IMIN+1) + TEMP = WORK(IV1TCS+IMIN-1)*B21D(IMIN) + + $ WORK(IV1TSN+IMIN-1)*B21E(IMIN) + B21E(IMIN) = WORK(IV1TCS+IMIN-1)*B21E(IMIN) - + $ WORK(IV1TSN+IMIN-1)*B21D(IMIN) + B21D(IMIN) = TEMP + B21BULGE = WORK(IV1TSN+IMIN-1)*B21D(IMIN+1) + B21D(IMIN+1) = WORK(IV1TCS+IMIN-1)*B21D(IMIN+1) +* +* Compute THETA(IMIN) +* + THETA( IMIN ) = ATAN2( SQRT( B21D(IMIN)**2+B21BULGE**2 ), + $ SQRT( B11D(IMIN)**2+B11BULGE**2 ) ) +* +* Chase the bulges in B11(IMIN+1,IMIN) and B21(IMIN+1,IMIN) +* + IF( B11D(IMIN)**2+B11BULGE**2 .GT. THRESH**2 ) THEN + CALL DLARTGP( B11BULGE, B11D(IMIN), WORK(IU1SN+IMIN-1), + $ WORK(IU1CS+IMIN-1), R ) + ELSE IF( MU .LE. NU ) THEN + CALL DLARTGS( B11E( IMIN ), B11D( IMIN + 1 ), MU, + $ WORK(IU1CS+IMIN-1), WORK(IU1SN+IMIN-1) ) + ELSE + CALL DLARTGS( B12D( IMIN ), B12E( IMIN ), NU, + $ WORK(IU1CS+IMIN-1), WORK(IU1SN+IMIN-1) ) + END IF + IF( B21D(IMIN)**2+B21BULGE**2 .GT. THRESH**2 ) THEN + CALL DLARTGP( B21BULGE, B21D(IMIN), WORK(IU2SN+IMIN-1), + $ WORK(IU2CS+IMIN-1), R ) + ELSE IF( NU .LT. MU ) THEN + CALL DLARTGS( B21E( IMIN ), B21D( IMIN + 1 ), NU, + $ WORK(IU2CS+IMIN-1), WORK(IU2SN+IMIN-1) ) + ELSE + CALL DLARTGS( B22D(IMIN), B22E(IMIN), MU, + $ WORK(IU2CS+IMIN-1), WORK(IU2SN+IMIN-1) ) + END IF + WORK(IU2CS+IMIN-1) = -WORK(IU2CS+IMIN-1) + WORK(IU2SN+IMIN-1) = -WORK(IU2SN+IMIN-1) +* + TEMP = WORK(IU1CS+IMIN-1)*B11E(IMIN) + + $ WORK(IU1SN+IMIN-1)*B11D(IMIN+1) + B11D(IMIN+1) = WORK(IU1CS+IMIN-1)*B11D(IMIN+1) - + $ WORK(IU1SN+IMIN-1)*B11E(IMIN) + B11E(IMIN) = TEMP + IF( IMAX .GT. IMIN+1 ) THEN + B11BULGE = WORK(IU1SN+IMIN-1)*B11E(IMIN+1) + B11E(IMIN+1) = WORK(IU1CS+IMIN-1)*B11E(IMIN+1) + END IF + TEMP = WORK(IU1CS+IMIN-1)*B12D(IMIN) + + $ WORK(IU1SN+IMIN-1)*B12E(IMIN) + B12E(IMIN) = WORK(IU1CS+IMIN-1)*B12E(IMIN) - + $ WORK(IU1SN+IMIN-1)*B12D(IMIN) + B12D(IMIN) = TEMP + B12BULGE = WORK(IU1SN+IMIN-1)*B12D(IMIN+1) + B12D(IMIN+1) = WORK(IU1CS+IMIN-1)*B12D(IMIN+1) + TEMP = WORK(IU2CS+IMIN-1)*B21E(IMIN) + + $ WORK(IU2SN+IMIN-1)*B21D(IMIN+1) + B21D(IMIN+1) = WORK(IU2CS+IMIN-1)*B21D(IMIN+1) - + $ WORK(IU2SN+IMIN-1)*B21E(IMIN) + B21E(IMIN) = TEMP + IF( IMAX .GT. IMIN+1 ) THEN + B21BULGE = WORK(IU2SN+IMIN-1)*B21E(IMIN+1) + B21E(IMIN+1) = WORK(IU2CS+IMIN-1)*B21E(IMIN+1) + END IF + TEMP = WORK(IU2CS+IMIN-1)*B22D(IMIN) + + $ WORK(IU2SN+IMIN-1)*B22E(IMIN) + B22E(IMIN) = WORK(IU2CS+IMIN-1)*B22E(IMIN) - + $ WORK(IU2SN+IMIN-1)*B22D(IMIN) + B22D(IMIN) = TEMP + B22BULGE = WORK(IU2SN+IMIN-1)*B22D(IMIN+1) + B22D(IMIN+1) = WORK(IU2CS+IMIN-1)*B22D(IMIN+1) +* +* Inner loop: chase bulges from B11(IMIN,IMIN+2), +* B12(IMIN,IMIN+1), B21(IMIN,IMIN+2), and B22(IMIN,IMIN+1) to +* bottom-right +* + DO I = IMIN+1, IMAX-1 +* +* Compute PHI(I-1) +* + X1 = SIN(THETA(I-1))*B11E(I-1) + COS(THETA(I-1))*B21E(I-1) + X2 = SIN(THETA(I-1))*B11BULGE + COS(THETA(I-1))*B21BULGE + Y1 = SIN(THETA(I-1))*B12D(I-1) + COS(THETA(I-1))*B22D(I-1) + Y2 = SIN(THETA(I-1))*B12BULGE + COS(THETA(I-1))*B22BULGE +* + PHI(I-1) = ATAN2( SQRT(X1**2+X2**2), SQRT(Y1**2+Y2**2) ) +* +* Determine if there are bulges to chase or if a new direct +* summand has been reached +* + RESTART11 = B11E(I-1)**2 + B11BULGE**2 .LE. THRESH**2 + RESTART21 = B21E(I-1)**2 + B21BULGE**2 .LE. THRESH**2 + RESTART12 = B12D(I-1)**2 + B12BULGE**2 .LE. THRESH**2 + RESTART22 = B22D(I-1)**2 + B22BULGE**2 .LE. THRESH**2 +* +* If possible, chase bulges from B11(I-1,I+1), B12(I-1,I), +* B21(I-1,I+1), and B22(I-1,I). If necessary, restart bulge- +* chasing by applying the original shift again. +* + IF( .NOT. RESTART11 .AND. .NOT. RESTART21 ) THEN + CALL DLARTGP( X2, X1, WORK(IV1TSN+I-1), WORK(IV1TCS+I-1), + $ R ) + ELSE IF( .NOT. RESTART11 .AND. RESTART21 ) THEN + CALL DLARTGP( B11BULGE, B11E(I-1), WORK(IV1TSN+I-1), + $ WORK(IV1TCS+I-1), R ) + ELSE IF( RESTART11 .AND. .NOT. RESTART21 ) THEN + CALL DLARTGP( B21BULGE, B21E(I-1), WORK(IV1TSN+I-1), + $ WORK(IV1TCS+I-1), R ) + ELSE IF( MU .LE. NU ) THEN + CALL DLARTGS( B11D(I), B11E(I), MU, WORK(IV1TCS+I-1), + $ WORK(IV1TSN+I-1) ) + ELSE + CALL DLARTGS( B21D(I), B21E(I), NU, WORK(IV1TCS+I-1), + $ WORK(IV1TSN+I-1) ) + END IF + WORK(IV1TCS+I-1) = -WORK(IV1TCS+I-1) + WORK(IV1TSN+I-1) = -WORK(IV1TSN+I-1) + IF( .NOT. RESTART12 .AND. .NOT. RESTART22 ) THEN + CALL DLARTGP( Y2, Y1, WORK(IV2TSN+I-1-1), + $ WORK(IV2TCS+I-1-1), R ) + ELSE IF( .NOT. RESTART12 .AND. RESTART22 ) THEN + CALL DLARTGP( B12BULGE, B12D(I-1), WORK(IV2TSN+I-1-1), + $ WORK(IV2TCS+I-1-1), R ) + ELSE IF( RESTART12 .AND. .NOT. RESTART22 ) THEN + CALL DLARTGP( B22BULGE, B22D(I-1), WORK(IV2TSN+I-1-1), + $ WORK(IV2TCS+I-1-1), R ) + ELSE IF( NU .LT. MU ) THEN + CALL DLARTGS( B12E(I-1), B12D(I), NU, WORK(IV2TCS+I-1-1), + $ WORK(IV2TSN+I-1-1) ) + ELSE + CALL DLARTGS( B22E(I-1), B22D(I), MU, WORK(IV2TCS+I-1-1), + $ WORK(IV2TSN+I-1-1) ) + END IF +* + TEMP = WORK(IV1TCS+I-1)*B11D(I) + WORK(IV1TSN+I-1)*B11E(I) + B11E(I) = WORK(IV1TCS+I-1)*B11E(I) - + $ WORK(IV1TSN+I-1)*B11D(I) + B11D(I) = TEMP + B11BULGE = WORK(IV1TSN+I-1)*B11D(I+1) + B11D(I+1) = WORK(IV1TCS+I-1)*B11D(I+1) + TEMP = WORK(IV1TCS+I-1)*B21D(I) + WORK(IV1TSN+I-1)*B21E(I) + B21E(I) = WORK(IV1TCS+I-1)*B21E(I) - + $ WORK(IV1TSN+I-1)*B21D(I) + B21D(I) = TEMP + B21BULGE = WORK(IV1TSN+I-1)*B21D(I+1) + B21D(I+1) = WORK(IV1TCS+I-1)*B21D(I+1) + TEMP = WORK(IV2TCS+I-1-1)*B12E(I-1) + + $ WORK(IV2TSN+I-1-1)*B12D(I) + B12D(I) = WORK(IV2TCS+I-1-1)*B12D(I) - + $ WORK(IV2TSN+I-1-1)*B12E(I-1) + B12E(I-1) = TEMP + B12BULGE = WORK(IV2TSN+I-1-1)*B12E(I) + B12E(I) = WORK(IV2TCS+I-1-1)*B12E(I) + TEMP = WORK(IV2TCS+I-1-1)*B22E(I-1) + + $ WORK(IV2TSN+I-1-1)*B22D(I) + B22D(I) = WORK(IV2TCS+I-1-1)*B22D(I) - + $ WORK(IV2TSN+I-1-1)*B22E(I-1) + B22E(I-1) = TEMP + B22BULGE = WORK(IV2TSN+I-1-1)*B22E(I) + B22E(I) = WORK(IV2TCS+I-1-1)*B22E(I) +* +* Compute THETA(I) +* + X1 = COS(PHI(I-1))*B11D(I) + SIN(PHI(I-1))*B12E(I-1) + X2 = COS(PHI(I-1))*B11BULGE + SIN(PHI(I-1))*B12BULGE + Y1 = COS(PHI(I-1))*B21D(I) + SIN(PHI(I-1))*B22E(I-1) + Y2 = COS(PHI(I-1))*B21BULGE + SIN(PHI(I-1))*B22BULGE +* + THETA(I) = ATAN2( SQRT(Y1**2+Y2**2), SQRT(X1**2+X2**2) ) +* +* Determine if there are bulges to chase or if a new direct +* summand has been reached +* + RESTART11 = B11D(I)**2 + B11BULGE**2 .LE. THRESH**2 + RESTART12 = B12E(I-1)**2 + B12BULGE**2 .LE. THRESH**2 + RESTART21 = B21D(I)**2 + B21BULGE**2 .LE. THRESH**2 + RESTART22 = B22E(I-1)**2 + B22BULGE**2 .LE. THRESH**2 +* +* If possible, chase bulges from B11(I+1,I), B12(I+1,I-1), +* B21(I+1,I), and B22(I+1,I-1). If necessary, restart bulge- +* chasing by applying the original shift again. +* + IF( .NOT. RESTART11 .AND. .NOT. RESTART12 ) THEN + CALL DLARTGP( X2, X1, WORK(IU1SN+I-1), WORK(IU1CS+I-1), + $ R ) + ELSE IF( .NOT. RESTART11 .AND. RESTART12 ) THEN + CALL DLARTGP( B11BULGE, B11D(I), WORK(IU1SN+I-1), + $ WORK(IU1CS+I-1), R ) + ELSE IF( RESTART11 .AND. .NOT. RESTART12 ) THEN + CALL DLARTGP( B12BULGE, B12E(I-1), WORK(IU1SN+I-1), + $ WORK(IU1CS+I-1), R ) + ELSE IF( MU .LE. NU ) THEN + CALL DLARTGS( B11E(I), B11D(I+1), MU, WORK(IU1CS+I-1), + $ WORK(IU1SN+I-1) ) + ELSE + CALL DLARTGS( B12D(I), B12E(I), NU, WORK(IU1CS+I-1), + $ WORK(IU1SN+I-1) ) + END IF + IF( .NOT. RESTART21 .AND. .NOT. RESTART22 ) THEN + CALL DLARTGP( Y2, Y1, WORK(IU2SN+I-1), WORK(IU2CS+I-1), + $ R ) + ELSE IF( .NOT. RESTART21 .AND. RESTART22 ) THEN + CALL DLARTGP( B21BULGE, B21D(I), WORK(IU2SN+I-1), + $ WORK(IU2CS+I-1), R ) + ELSE IF( RESTART21 .AND. .NOT. RESTART22 ) THEN + CALL DLARTGP( B22BULGE, B22E(I-1), WORK(IU2SN+I-1), + $ WORK(IU2CS+I-1), R ) + ELSE IF( NU .LT. MU ) THEN + CALL DLARTGS( B21E(I), B21E(I+1), NU, WORK(IU2CS+I-1), + $ WORK(IU2SN+I-1) ) + ELSE + CALL DLARTGS( B22D(I), B22E(I), MU, WORK(IU2CS+I-1), + $ WORK(IU2SN+I-1) ) + END IF + WORK(IU2CS+I-1) = -WORK(IU2CS+I-1) + WORK(IU2SN+I-1) = -WORK(IU2SN+I-1) +* + TEMP = WORK(IU1CS+I-1)*B11E(I) + WORK(IU1SN+I-1)*B11D(I+1) + B11D(I+1) = WORK(IU1CS+I-1)*B11D(I+1) - + $ WORK(IU1SN+I-1)*B11E(I) + B11E(I) = TEMP + IF( I .LT. IMAX - 1 ) THEN + B11BULGE = WORK(IU1SN+I-1)*B11E(I+1) + B11E(I+1) = WORK(IU1CS+I-1)*B11E(I+1) + END IF + TEMP = WORK(IU2CS+I-1)*B21E(I) + WORK(IU2SN+I-1)*B21D(I+1) + B21D(I+1) = WORK(IU2CS+I-1)*B21D(I+1) - + $ WORK(IU2SN+I-1)*B21E(I) + B21E(I) = TEMP + IF( I .LT. IMAX - 1 ) THEN + B21BULGE = WORK(IU2SN+I-1)*B21E(I+1) + B21E(I+1) = WORK(IU2CS+I-1)*B21E(I+1) + END IF + TEMP = WORK(IU1CS+I-1)*B12D(I) + WORK(IU1SN+I-1)*B12E(I) + B12E(I) = WORK(IU1CS+I-1)*B12E(I) - WORK(IU1SN+I-1)*B12D(I) + B12D(I) = TEMP + B12BULGE = WORK(IU1SN+I-1)*B12D(I+1) + B12D(I+1) = WORK(IU1CS+I-1)*B12D(I+1) + TEMP = WORK(IU2CS+I-1)*B22D(I) + WORK(IU2SN+I-1)*B22E(I) + B22E(I) = WORK(IU2CS+I-1)*B22E(I) - WORK(IU2SN+I-1)*B22D(I) + B22D(I) = TEMP + B22BULGE = WORK(IU2SN+I-1)*B22D(I+1) + B22D(I+1) = WORK(IU2CS+I-1)*B22D(I+1) +* + END DO +* +* Compute PHI(IMAX-1) +* + X1 = SIN(THETA(IMAX-1))*B11E(IMAX-1) + + $ COS(THETA(IMAX-1))*B21E(IMAX-1) + Y1 = SIN(THETA(IMAX-1))*B12D(IMAX-1) + + $ COS(THETA(IMAX-1))*B22D(IMAX-1) + Y2 = SIN(THETA(IMAX-1))*B12BULGE + COS(THETA(IMAX-1))*B22BULGE +* + PHI(IMAX-1) = ATAN2( ABS(X1), SQRT(Y1**2+Y2**2) ) +* +* Chase bulges from B12(IMAX-1,IMAX) and B22(IMAX-1,IMAX) +* + RESTART12 = B12D(IMAX-1)**2 + B12BULGE**2 .LE. THRESH**2 + RESTART22 = B22D(IMAX-1)**2 + B22BULGE**2 .LE. THRESH**2 +* + IF( .NOT. RESTART12 .AND. .NOT. RESTART22 ) THEN + CALL DLARTGP( Y2, Y1, WORK(IV2TSN+IMAX-1-1), + $ WORK(IV2TCS+IMAX-1-1), R ) + ELSE IF( .NOT. RESTART12 .AND. RESTART22 ) THEN + CALL DLARTGP( B12BULGE, B12D(IMAX-1), WORK(IV2TSN+IMAX-1-1), + $ WORK(IV2TCS+IMAX-1-1), R ) + ELSE IF( RESTART12 .AND. .NOT. RESTART22 ) THEN + CALL DLARTGP( B22BULGE, B22D(IMAX-1), WORK(IV2TSN+IMAX-1-1), + $ WORK(IV2TCS+IMAX-1-1), R ) + ELSE IF( NU .LT. MU ) THEN + CALL DLARTGS( B12E(IMAX-1), B12D(IMAX), NU, + $ WORK(IV2TCS+IMAX-1-1), WORK(IV2TSN+IMAX-1-1) ) + ELSE + CALL DLARTGS( B22E(IMAX-1), B22D(IMAX), MU, + $ WORK(IV2TCS+IMAX-1-1), WORK(IV2TSN+IMAX-1-1) ) + END IF +* + TEMP = WORK(IV2TCS+IMAX-1-1)*B12E(IMAX-1) + + $ WORK(IV2TSN+IMAX-1-1)*B12D(IMAX) + B12D(IMAX) = WORK(IV2TCS+IMAX-1-1)*B12D(IMAX) - + $ WORK(IV2TSN+IMAX-1-1)*B12E(IMAX-1) + B12E(IMAX-1) = TEMP + TEMP = WORK(IV2TCS+IMAX-1-1)*B22E(IMAX-1) + + $ WORK(IV2TSN+IMAX-1-1)*B22D(IMAX) + B22D(IMAX) = WORK(IV2TCS+IMAX-1-1)*B22D(IMAX) - + $ WORK(IV2TSN+IMAX-1-1)*B22E(IMAX-1) + B22E(IMAX-1) = TEMP +* +* Update singular vectors +* + IF( WANTU1 ) THEN + IF( COLMAJOR ) THEN + CALL DLASR( 'R', 'V', 'F', P, IMAX-IMIN+1, + $ WORK(IU1CS+IMIN-1), WORK(IU1SN+IMIN-1), + $ U1(1,IMIN), LDU1 ) + ELSE + CALL DLASR( 'L', 'V', 'F', IMAX-IMIN+1, P, + $ WORK(IU1CS+IMIN-1), WORK(IU1SN+IMIN-1), + $ U1(IMIN,1), LDU1 ) + END IF + END IF + IF( WANTU2 ) THEN + IF( COLMAJOR ) THEN + CALL DLASR( 'R', 'V', 'F', M-P, IMAX-IMIN+1, + $ WORK(IU2CS+IMIN-1), WORK(IU2SN+IMIN-1), + $ U2(1,IMIN), LDU2 ) + ELSE + CALL DLASR( 'L', 'V', 'F', IMAX-IMIN+1, M-P, + $ WORK(IU2CS+IMIN-1), WORK(IU2SN+IMIN-1), + $ U2(IMIN,1), LDU2 ) + END IF + END IF + IF( WANTV1T ) THEN + IF( COLMAJOR ) THEN + CALL DLASR( 'L', 'V', 'F', IMAX-IMIN+1, Q, + $ WORK(IV1TCS+IMIN-1), WORK(IV1TSN+IMIN-1), + $ V1T(IMIN,1), LDV1T ) + ELSE + CALL DLASR( 'R', 'V', 'F', Q, IMAX-IMIN+1, + $ WORK(IV1TCS+IMIN-1), WORK(IV1TSN+IMIN-1), + $ V1T(1,IMIN), LDV1T ) + END IF + END IF + IF( WANTV2T ) THEN + IF( COLMAJOR ) THEN + CALL DLASR( 'L', 'V', 'F', IMAX-IMIN+1, M-Q, + $ WORK(IV2TCS+IMIN-1), WORK(IV2TSN+IMIN-1), + $ V2T(IMIN,1), LDV2T ) + ELSE + CALL DLASR( 'R', 'V', 'F', M-Q, IMAX-IMIN+1, + $ WORK(IV2TCS+IMIN-1), WORK(IV2TSN+IMIN-1), + $ V2T(1,IMIN), LDV2T ) + END IF + END IF +* +* Fix signs on B11(IMAX-1,IMAX) and B21(IMAX-1,IMAX) +* + IF( B11E(IMAX-1)+B21E(IMAX-1) .GT. 0 ) THEN + B11D(IMAX) = -B11D(IMAX) + B21D(IMAX) = -B21D(IMAX) + IF( WANTV1T ) THEN + IF( COLMAJOR ) THEN + CALL DSCAL( Q, NEGONE, V1T(IMAX,1), LDV1T ) + ELSE + CALL DSCAL( Q, NEGONE, V1T(1,IMAX), 1 ) + END IF + END IF + END IF +* +* Compute THETA(IMAX) +* + X1 = COS(PHI(IMAX-1))*B11D(IMAX) + + $ SIN(PHI(IMAX-1))*B12E(IMAX-1) + Y1 = COS(PHI(IMAX-1))*B21D(IMAX) + + $ SIN(PHI(IMAX-1))*B22E(IMAX-1) +* + THETA(IMAX) = ATAN2( ABS(Y1), ABS(X1) ) +* +* Fix signs on B11(IMAX,IMAX), B12(IMAX,IMAX-1), B21(IMAX,IMAX), +* and B22(IMAX,IMAX-1) +* + IF( B11D(IMAX)+B12E(IMAX-1) .LT. 0 ) THEN + B12D(IMAX) = -B12D(IMAX) + IF( WANTU1 ) THEN + IF( COLMAJOR ) THEN + CALL DSCAL( P, NEGONE, U1(1,IMAX), 1 ) + ELSE + CALL DSCAL( P, NEGONE, U1(IMAX,1), LDU1 ) + END IF + END IF + END IF + IF( B21D(IMAX)+B22E(IMAX-1) .GT. 0 ) THEN + B22D(IMAX) = -B22D(IMAX) + IF( WANTU2 ) THEN + IF( COLMAJOR ) THEN + CALL DSCAL( M-P, NEGONE, U2(1,IMAX), 1 ) + ELSE + CALL DSCAL( M-P, NEGONE, U2(IMAX,1), LDU2 ) + END IF + END IF + END IF +* +* Fix signs on B12(IMAX,IMAX) and B22(IMAX,IMAX) +* + IF( B12D(IMAX)+B22D(IMAX) .LT. 0 ) THEN + IF( WANTV2T ) THEN + IF( COLMAJOR ) THEN + CALL DSCAL( M-Q, NEGONE, V2T(IMAX,1), LDV2T ) + ELSE + CALL DSCAL( M-Q, NEGONE, V2T(1,IMAX), 1 ) + END IF + END IF + END IF +* +* Test for negligible sines or cosines +* + DO I = IMIN, IMAX + IF( THETA(I) .LT. THRESH ) THEN + THETA(I) = ZERO + ELSE IF( THETA(I) .GT. PIOVER2-THRESH ) THEN + THETA(I) = PIOVER2 + END IF + END DO + DO I = IMIN, IMAX-1 + IF( PHI(I) .LT. THRESH ) THEN + PHI(I) = ZERO + ELSE IF( PHI(I) .GT. PIOVER2-THRESH ) THEN + PHI(I) = PIOVER2 + END IF + END DO +* +* Deflate +* + IF (IMAX .GT. 1) THEN + DO WHILE( PHI(IMAX-1) .EQ. ZERO ) + IMAX = IMAX - 1 + IF (IMAX .LE. 1) EXIT + END DO + END IF + IF( IMIN .GT. IMAX - 1 ) + $ IMIN = IMAX - 1 + IF (IMIN .GT. 1) THEN + DO WHILE (PHI(IMIN-1) .NE. ZERO) + IMIN = IMIN - 1 + IF (IMIN .LE. 1) EXIT + END DO + END IF +* +* Repeat main iteration loop +* + END DO +* +* Postprocessing: order THETA from least to greatest +* + DO I = 1, Q +* + MINI = I + THETAMIN = THETA(I) + DO J = I+1, Q + IF( THETA(J) .LT. THETAMIN ) THEN + MINI = J + THETAMIN = THETA(J) + END IF + END DO +* + IF( MINI .NE. I ) THEN + THETA(MINI) = THETA(I) + THETA(I) = THETAMIN + IF( COLMAJOR ) THEN + IF( WANTU1 ) + $ CALL DSWAP( P, U1(1,I), 1, U1(1,MINI), 1 ) + IF( WANTU2 ) + $ CALL DSWAP( M-P, U2(1,I), 1, U2(1,MINI), 1 ) + IF( WANTV1T ) + $ CALL DSWAP( Q, V1T(I,1), LDV1T, V1T(MINI,1), LDV1T ) + IF( WANTV2T ) + $ CALL DSWAP( M-Q, V2T(I,1), LDV2T, V2T(MINI,1), + $ LDV2T ) + ELSE + IF( WANTU1 ) + $ CALL DSWAP( P, U1(I,1), LDU1, U1(MINI,1), LDU1 ) + IF( WANTU2 ) + $ CALL DSWAP( M-P, U2(I,1), LDU2, U2(MINI,1), LDU2 ) + IF( WANTV1T ) + $ CALL DSWAP( Q, V1T(1,I), 1, V1T(1,MINI), 1 ) + IF( WANTV2T ) + $ CALL DSWAP( M-Q, V2T(1,I), 1, V2T(1,MINI), 1 ) + END IF + END IF +* + END DO +* + RETURN +* +* End of DBBCSD +* + END + diff --git a/math/lapack/src/main/fortran/dbdsdc.f b/math/lapack/src/main/fortran/dbdsdc.f new file mode 100644 index 0000000000..e349b0cc08 --- /dev/null +++ b/math/lapack/src/main/fortran/dbdsdc.f @@ -0,0 +1,524 @@ +*> \brief \b DBDSDC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DBDSDC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER COMPQ, UPLO +* INTEGER INFO, LDU, LDVT, N +* .. +* .. Array Arguments .. +* INTEGER IQ( * ), IWORK( * ) +* DOUBLE PRECISION D( * ), E( * ), Q( * ), U( LDU, * ), +* $ VT( LDVT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DBDSDC computes the singular value decomposition (SVD) of a real +*> N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, +*> using a divide and conquer method, where S is a diagonal matrix +*> with non-negative diagonal elements (the singular values of B), and +*> U and VT are orthogonal matrices of left and right singular vectors, +*> respectively. DBDSDC can be used to compute all singular values, +*> and optionally, singular vectors or singular vectors in compact form. +*> +*> This code makes very mild assumptions about floating point +*> arithmetic. It will work on machines with a guard digit in +*> add/subtract, or on those binary machines without guard digits +*> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. +*> It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. See DLASD3 for details. +*> +*> The code currently calls DLASDQ if singular values only are desired. +*> However, it can be slightly modified to compute singular values +*> using the divide and conquer method. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': B is upper bidiagonal. +*> = 'L': B is lower bidiagonal. +*> \endverbatim +*> +*> \param[in] COMPQ +*> \verbatim +*> COMPQ is CHARACTER*1 +*> Specifies whether singular vectors are to be computed +*> as follows: +*> = 'N': Compute singular values only; +*> = 'P': Compute singular values and compute singular +*> vectors in compact form; +*> = 'I': Compute singular values and singular vectors. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is 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. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> On entry, the elements of E contain the offdiagonal +*> elements of the bidiagonal matrix whose SVD is desired. +*> On exit, E has been destroyed. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension (LDU,N) +*> If COMPQ = 'I', then: +*> On exit, if INFO = 0, U contains the left singular vectors +*> of the bidiagonal matrix. +*> For other values of COMPQ, U is not referenced. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of the array U. LDU >= 1. +*> If singular vectors are desired, then LDU >= max( 1, N ). +*> \endverbatim +*> +*> \param[out] VT +*> \verbatim +*> VT is DOUBLE PRECISION array, dimension (LDVT,N) +*> If COMPQ = 'I', then: +*> On exit, if INFO = 0, VT**T contains the right singular +*> vectors of the bidiagonal matrix. +*> For other values of COMPQ, VT is not referenced. +*> \endverbatim +*> +*> \param[in] LDVT +*> \verbatim +*> LDVT is INTEGER +*> The leading dimension of the array VT. LDVT >= 1. +*> If singular vectors are desired, then LDVT >= max( 1, N ). +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ) +*> If COMPQ = 'P', then: +*> On exit, if INFO = 0, Q and IQ contain the left +*> and right singular vectors in a compact form, +*> requiring O(N log N) space instead of 2*N**2. +*> In particular, Q contains all the DOUBLE PRECISION data in +*> LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1)))) +*> words of memory, where SMLSIZ is returned by ILAENV and +*> is equal to the maximum size of the subproblems at the +*> bottom of the computation tree (usually about 25). +*> For other values of COMPQ, Q is not referenced. +*> \endverbatim +*> +*> \param[out] IQ +*> \verbatim +*> IQ is INTEGER array, dimension (LDIQ) +*> If COMPQ = 'P', then: +*> On exit, if INFO = 0, Q and IQ contain the left +*> and right singular vectors in a compact form, +*> requiring O(N log N) space instead of 2*N**2. +*> In particular, IQ contains all INTEGER data in +*> LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1)))) +*> words of memory, where SMLSIZ is returned by ILAENV and +*> is equal to the maximum size of the subproblems at the +*> bottom of the computation tree (usually about 25). +*> For other values of COMPQ, IQ is not referenced. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> If COMPQ = 'N' then LWORK >= (4 * N). +*> If COMPQ = 'P' then LWORK >= (6 * N). +*> If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N). +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (8*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: The algorithm failed to compute a singular value. +*> The update process of divide and conquer failed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup auxOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, + $ WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER COMPQ, UPLO + INTEGER INFO, LDU, LDVT, N +* .. +* .. Array Arguments .. + INTEGER IQ( * ), IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), Q( * ), U( LDU, * ), + $ VT( LDVT, * ), WORK( * ) +* .. +* +* ===================================================================== +* Changed dimension statement in comment describing E from (N) to +* (N-1). Sven, 17 Feb 05. +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC, + $ ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK, + $ MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ, + $ SMLSZP, SQRE, START, WSTART, Z + DOUBLE PRECISION CS, EPS, ORGNRM, P, R, SN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANST + EXTERNAL LSAME, ILAENV, DLAMCH, DLANST +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLARTG, DLASCL, DLASD0, DLASDA, DLASDQ, + $ DLASET, DLASR, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG, SIGN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IUPLO = 0 + IF( LSAME( UPLO, 'U' ) ) + $ IUPLO = 1 + IF( LSAME( UPLO, 'L' ) ) + $ IUPLO = 2 + IF( LSAME( COMPQ, 'N' ) ) THEN + ICOMPQ = 0 + ELSE IF( LSAME( COMPQ, 'P' ) ) THEN + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ICOMPQ = 2 + ELSE + ICOMPQ = -1 + END IF + IF( IUPLO.EQ.0 ) THEN + INFO = -1 + ELSE IF( ICOMPQ.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ( LDU.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDU.LT. + $ N ) ) ) THEN + INFO = -7 + ELSE IF( ( LDVT.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDVT.LT. + $ N ) ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DBDSDC', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + SMLSIZ = ILAENV( 9, 'DBDSDC', ' ', 0, 0, 0, 0 ) + IF( N.EQ.1 ) THEN + IF( ICOMPQ.EQ.1 ) THEN + Q( 1 ) = SIGN( ONE, D( 1 ) ) + Q( 1+SMLSIZ*N ) = ONE + ELSE IF( ICOMPQ.EQ.2 ) THEN + U( 1, 1 ) = SIGN( ONE, D( 1 ) ) + VT( 1, 1 ) = ONE + END IF + D( 1 ) = ABS( D( 1 ) ) + RETURN + END IF + NM1 = N - 1 +* +* If matrix lower bidiagonal, rotate to be upper bidiagonal +* by applying Givens rotations on the left +* + WSTART = 1 + QSTART = 3 + IF( ICOMPQ.EQ.1 ) THEN + CALL DCOPY( N, D, 1, Q( 1 ), 1 ) + CALL DCOPY( N-1, E, 1, Q( N+1 ), 1 ) + END IF + IF( IUPLO.EQ.2 ) THEN + QSTART = 5 + WSTART = 2*N - 1 + 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 ) + IF( ICOMPQ.EQ.1 ) THEN + Q( I+2*N ) = CS + Q( I+3*N ) = SN + ELSE IF( ICOMPQ.EQ.2 ) THEN + WORK( I ) = CS + WORK( NM1+I ) = -SN + END IF + 10 CONTINUE + END IF +* +* If ICOMPQ = 0, use DLASDQ to compute the singular values. +* + IF( ICOMPQ.EQ.0 ) THEN +* Ignore WSTART, instead using WORK( 1 ), since the two vectors +* for CS and -SN above are added only if ICOMPQ == 2, +* and adding them exceeds documented WORK size of 4*n. + CALL DLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U, + $ LDU, WORK( 1 ), INFO ) + GO TO 40 + END IF +* +* If N is smaller than the minimum divide size SMLSIZ, then solve +* the problem with another solver. +* + IF( N.LE.SMLSIZ ) THEN + IF( ICOMPQ.EQ.2 ) THEN + CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU ) + CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT ) + CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, VT, LDVT, U, LDU, U, + $ LDU, WORK( WSTART ), INFO ) + ELSE IF( ICOMPQ.EQ.1 ) THEN + IU = 1 + IVT = IU + N + CALL DLASET( 'A', N, N, ZERO, ONE, Q( IU+( QSTART-1 )*N ), + $ N ) + CALL DLASET( 'A', N, N, ZERO, ONE, Q( IVT+( QSTART-1 )*N ), + $ N ) + CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, + $ Q( IVT+( QSTART-1 )*N ), N, + $ Q( IU+( QSTART-1 )*N ), N, + $ Q( IU+( QSTART-1 )*N ), N, WORK( WSTART ), + $ INFO ) + END IF + GO TO 40 + END IF +* + IF( ICOMPQ.EQ.2 ) THEN + CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU ) + CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT ) + END IF +* +* Scale. +* + ORGNRM = DLANST( 'M', N, D, E ) + IF( ORGNRM.EQ.ZERO ) + $ RETURN + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, IERR ) + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, IERR ) +* + EPS = (0.9D+0)*DLAMCH( 'Epsilon' ) +* + MLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1 + SMLSZP = SMLSIZ + 1 +* + IF( ICOMPQ.EQ.1 ) THEN + IU = 1 + IVT = 1 + SMLSIZ + DIFL = IVT + SMLSZP + DIFR = DIFL + MLVL + Z = DIFR + MLVL*2 + IC = Z + MLVL + IS = IC + 1 + POLES = IS + 1 + GIVNUM = POLES + 2*MLVL +* + K = 1 + GIVPTR = 2 + PERM = 3 + GIVCOL = PERM + MLVL + END IF +* + DO 20 I = 1, N + IF( ABS( D( I ) ).LT.EPS ) THEN + D( I ) = SIGN( EPS, D( I ) ) + END IF + 20 CONTINUE +* + START = 1 + SQRE = 0 +* + DO 30 I = 1, NM1 + IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN +* +* Subproblem found. First determine its size and then +* apply divide and conquer on it. +* + IF( I.LT.NM1 ) THEN +* +* A subproblem with E(I) small for I < NM1. +* + NSIZE = I - START + 1 + ELSE IF( ABS( E( I ) ).GE.EPS ) THEN +* +* A subproblem with E(NM1) not too small but I = NM1. +* + NSIZE = N - START + 1 + ELSE +* +* A subproblem with E(NM1) small. This implies an +* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem +* first. +* + NSIZE = I - START + 1 + IF( ICOMPQ.EQ.2 ) THEN + U( N, N ) = SIGN( ONE, D( N ) ) + VT( N, N ) = ONE + ELSE IF( ICOMPQ.EQ.1 ) THEN + Q( N+( QSTART-1 )*N ) = SIGN( ONE, D( N ) ) + Q( N+( SMLSIZ+QSTART-1 )*N ) = ONE + END IF + D( N ) = ABS( D( N ) ) + END IF + IF( ICOMPQ.EQ.2 ) THEN + CALL DLASD0( NSIZE, SQRE, D( START ), E( START ), + $ U( START, START ), LDU, VT( START, START ), + $ LDVT, SMLSIZ, IWORK, WORK( WSTART ), INFO ) + ELSE + CALL DLASDA( ICOMPQ, SMLSIZ, NSIZE, SQRE, D( START ), + $ E( START ), Q( START+( IU+QSTART-2 )*N ), N, + $ Q( START+( IVT+QSTART-2 )*N ), + $ IQ( START+K*N ), Q( START+( DIFL+QSTART-2 )* + $ N ), Q( START+( DIFR+QSTART-2 )*N ), + $ Q( START+( Z+QSTART-2 )*N ), + $ Q( START+( POLES+QSTART-2 )*N ), + $ IQ( START+GIVPTR*N ), IQ( START+GIVCOL*N ), + $ N, IQ( START+PERM*N ), + $ Q( START+( GIVNUM+QSTART-2 )*N ), + $ Q( START+( IC+QSTART-2 )*N ), + $ Q( START+( IS+QSTART-2 )*N ), + $ WORK( WSTART ), IWORK, INFO ) + END IF + IF( INFO.NE.0 ) THEN + RETURN + END IF + START = I + 1 + END IF + 30 CONTINUE +* +* Unscale +* + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, IERR ) + 40 CONTINUE +* +* Use Selection Sort to minimize swaps of singular vectors +* + DO 60 II = 2, N + I = II - 1 + KK = I + P = D( I ) + DO 50 J = II, N + IF( D( J ).GT.P ) THEN + KK = J + P = D( J ) + END IF + 50 CONTINUE + IF( KK.NE.I ) THEN + D( KK ) = D( I ) + D( I ) = P + IF( ICOMPQ.EQ.1 ) THEN + IQ( I ) = KK + ELSE IF( ICOMPQ.EQ.2 ) THEN + CALL DSWAP( N, U( 1, I ), 1, U( 1, KK ), 1 ) + CALL DSWAP( N, VT( I, 1 ), LDVT, VT( KK, 1 ), LDVT ) + END IF + ELSE IF( ICOMPQ.EQ.1 ) THEN + IQ( I ) = I + END IF + 60 CONTINUE +* +* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO +* + IF( ICOMPQ.EQ.1 ) THEN + IF( IUPLO.EQ.1 ) THEN + IQ( N ) = 1 + ELSE + IQ( N ) = 0 + END IF + END IF +* +* If B is lower bidiagonal, update U by those Givens rotations +* which rotated B to be upper bidiagonal +* + IF( ( IUPLO.EQ.2 ) .AND. ( ICOMPQ.EQ.2 ) ) + $ CALL DLASR( 'L', 'V', 'B', N, N, WORK( 1 ), WORK( N ), U, LDU ) +* + RETURN +* +* End of DBDSDC +* + END diff --git a/math/lapack/src/main/fortran/dbdsqr.f b/math/lapack/src/main/fortran/dbdsqr.f new file mode 100644 index 0000000000..b9894d897a --- /dev/null +++ b/math/lapack/src/main/fortran/dbdsqr.f @@ -0,0 +1,850 @@ +*> \brief \b DBDSQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DBDSQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, +* LDU, C, LDC, WORK, INFO ) +* +* .. 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( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': B is upper bidiagonal; +*> = 'L': B is lower bidiagonal. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix B. N >= 0. +*> \endverbatim +*> +*> \param[in] NCVT +*> \verbatim +*> NCVT is INTEGER +*> The number of columns of the matrix VT. NCVT >= 0. +*> \endverbatim +*> +*> \param[in] NRU +*> \verbatim +*> NRU is INTEGER +*> The number of rows of the matrix U. NRU >= 0. +*> \endverbatim +*> +*> \param[in] NCC +*> \verbatim +*> NCC is INTEGER +*> The number of columns of the matrix C. NCC >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is 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. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is 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. +*> \endverbatim +*> +*> \param[in,out] VT +*> \verbatim +*> VT is 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. +*> \endverbatim +*> +*> \param[in] LDVT +*> \verbatim +*> LDVT is INTEGER +*> The leading dimension of the array VT. +*> LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. +*> \endverbatim +*> +*> \param[in,out] U +*> \verbatim +*> U is 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. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of the array U. LDU >= max(1,NRU). +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is 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. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. +*> LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: If INFO = -i, the i-th argument had an illegal value +*> > 0: +*> if NCVT = NRU = NCC = 0, +*> = 1, a split was marked by a positive value in E +*> = 2, current block of Z not diagonalized after 30*N +*> iterations (in inner while loop) +*> = 3, termination criterion of outer while loop not met +*> (program created more than N unreduced blocks) +*> else NCVT = NRU = NCC = 0, +*> the algorithm did not converge; D and E contain the +*> elements of a bidiagonal matrix which is orthogonally +*> similar to the input matrix B; if INFO = i, i +*> elements of E have not converged to zero. +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, + $ LDU, C, LDC, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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( * ) +* .. +* +* ===================================================================== +* +* .. 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 ) +* +* If INFO equals 2, dqds didn't finish, try to finish +* + IF( INFO .NE. 2 ) RETURN + INFO = 0 + 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/math/lapack/src/main/fortran/dbdsvdx.f b/math/lapack/src/main/fortran/dbdsvdx.f new file mode 100644 index 0000000000..94f52b4e60 --- /dev/null +++ b/math/lapack/src/main/fortran/dbdsvdx.f @@ -0,0 +1,792 @@ +*> \brief \b DBDSVDX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DBDSVDX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, +* $ NS, S, Z, LDZ, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, LDZ, N, NS +* DOUBLE PRECISION VL, VU +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION D( * ), E( * ), S( * ), WORK( * ), +* Z( LDZ, * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DBDSVDX computes the singular value decomposition (SVD) of a real +*> N-by-N (upper or lower) bidiagonal matrix B, B = U * S * VT, +*> where S is a diagonal matrix with non-negative diagonal elements +*> (the singular values of B), and U and VT are orthogonal matrices +*> of left and right singular vectors, respectively. +*> +*> Given an upper bidiagonal B with diagonal D = [ d_1 d_2 ... d_N ] +*> and superdiagonal E = [ e_1 e_2 ... e_N-1 ], DBDSVDX computes the +*> singular value decompositon of B through the eigenvalues and +*> eigenvectors of the N*2-by-N*2 tridiagonal matrix +*> +*> | 0 d_1 | +*> | d_1 0 e_1 | +*> TGK = | e_1 0 d_2 | +*> | d_2 . . | +*> | . . . | +*> +*> If (s,u,v) is a singular triplet of B with ||u|| = ||v|| = 1, then +*> (+/-s,q), ||q|| = 1, are eigenpairs of TGK, with q = P * ( u' +/-v' ) / +*> sqrt(2) = ( v_1 u_1 v_2 u_2 ... v_n u_n ) / sqrt(2), and +*> P = [ e_{n+1} e_{1} e_{n+2} e_{2} ... ]. +*> +*> Given a TGK matrix, one can either a) compute -s,-v and change signs +*> so that the singular values (and corresponding vectors) are already in +*> descending order (as in DGESVD/DGESDD) or b) compute s,v and reorder +*> the values (and corresponding vectors). DBDSVDX implements a) by +*> calling DSTEVX (bisection plus inverse iteration, to be replaced +*> with a version of the Multiple Relative Robust Representation +*> algorithm. (See P. Willems and B. Lang, A framework for the MR^3 +*> algorithm: theory and implementation, SIAM J. Sci. Comput., +*> 35:740-766, 2013.) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': B is upper bidiagonal; +*> = 'L': B is lower bidiagonal. +*> \endverbatim +*> +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute singular values only; +*> = 'V': Compute singular values and singular vectors. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all singular values will be found. +*> = 'V': all singular values in the half-open interval [VL,VU) +*> will be found. +*> = 'I': the IL-th through IU-th singular values will be found. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the bidiagonal matrix. N >= 0. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of the bidiagonal matrix B. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (max(1,N-1)) +*> The (n-1) superdiagonal elements of the bidiagonal matrix +*> B in elements 1 to N-1. +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for singular values. VU > VL. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for singular values. VU > VL. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest singular value to be returned. +*> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest singular value to be returned. +*> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[out] NS +*> \verbatim +*> NS is INTEGER +*> The total number of singular values found. 0 <= NS <= N. +*> If RANGE = 'A', NS = N, and if RANGE = 'I', NS = IU-IL+1. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N) +*> The first NS elements contain the selected singular values in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (2*N,K) ) +*> If JOBZ = 'V', then if INFO = 0 the first NS columns of Z +*> contain the singular vectors of the matrix B corresponding to +*> the selected singular values, with U in rows 1 to N and V +*> in rows N+1 to N*2, i.e. +*> Z = [ U ] +*> [ V ] +*> If JOBZ = 'N', then Z is not referenced. +*> Note: The user must ensure that at least K = NS+1 columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of +*> NS is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(2,N*2). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (14*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (12*N) +*> If JOBZ = 'V', then if INFO = 0, the first NS elements of +*> IWORK are zero. If INFO > 0, then IWORK contains the indices +*> of the eigenvectors that failed to converge in DSTEVX. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, then i eigenvectors failed to converge +*> in DSTEVX. The indices of the eigenvectors +*> (as returned by DSTEVX) are stored in the +*> array IWORK. +*> if INFO = N*2 + 1, an internal error occurred. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHEReigen +* +* ===================================================================== + SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, + $ NS, S, Z, LDZ, WORK, IWORK, INFO) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, LDZ, N, NS + DOUBLE PRECISION VL, VU +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), S( * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TEN, HNDRD, MEIGTH + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0, + $ HNDRD = 100.0D0, MEIGTH = -0.1250D0 ) + DOUBLE PRECISION FUDGE + PARAMETER ( FUDGE = 2.0D0 ) +* .. +* .. Local Scalars .. + CHARACTER RNGVX + LOGICAL ALLSV, INDSV, LOWER, SPLIT, SVEQ0, VALSV, WANTZ + INTEGER I, ICOLZ, IDBEG, IDEND, IDTGK, IDPTR, IEPTR, + $ IETGK, IIFAIL, IIWORK, ILTGK, IROWU, IROWV, + $ IROWZ, ISBEG, ISPLT, ITEMP, IUTGK, J, K, + $ NTGK, NRU, NRV, NSL + DOUBLE PRECISION ABSTOL, EPS, EMIN, MU, NRMU, NRMV, ORTOL, SMAX, + $ SMIN, SQRT2, THRESH, TOL, ULP, + $ VLTGK, VUTGK, ZJTJI +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DDOT, DLAMCH, DNRM2 + EXTERNAL IDAMAX, LSAME, DAXPY, DDOT, DLAMCH, DNRM2 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLASET, DSCAL, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + ALLSV = LSAME( RANGE, 'A' ) + VALSV = LSAME( RANGE, 'V' ) + INDSV = LSAME( RANGE, 'I' ) + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) +* + INFO = 0 + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN + INFO = -1 + ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( ALLSV .OR. VALSV .OR. INDSV ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( N.GT.0 ) THEN + IF( VALSV ) THEN + IF( VL.LT.ZERO ) THEN + INFO = -7 + ELSE IF( VU.LE.VL ) THEN + INFO = -8 + END IF + ELSE IF( INDSV ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -10 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N*2 ) ) INFO = -14 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DBDSVDX', -INFO ) + RETURN + END IF +* +* Quick return if possible (N.LE.1) +* + NS = 0 + IF( N.EQ.0 ) RETURN +* + IF( N.EQ.1 ) THEN + IF( ALLSV .OR. INDSV ) THEN + NS = 1 + S( 1 ) = ABS( D( 1 ) ) + ELSE + IF( VL.LT.ABS( D( 1 ) ) .AND. VU.GE.ABS( D( 1 ) ) ) THEN + NS = 1 + S( 1 ) = ABS( D( 1 ) ) + END IF + END IF + IF( WANTZ ) THEN + Z( 1, 1 ) = SIGN( ONE, D( 1 ) ) + Z( 2, 1 ) = ONE + END IF + RETURN + END IF +* + ABSTOL = 2*DLAMCH( 'Safe Minimum' ) + ULP = DLAMCH( 'Precision' ) + EPS = DLAMCH( 'Epsilon' ) + SQRT2 = SQRT( 2.0D0 ) + ORTOL = SQRT( ULP ) +* +* Criterion for splitting is taken from DBDSQR when singular +* values are computed to relative accuracy TOL. (See J. Demmel and +* W. Kahan, Accurate singular values of bidiagonal matrices, SIAM +* J. Sci. and Stat. Comput., 11:873–912, 1990.) +* + TOL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )*EPS +* +* Compute approximate maximum, minimum singular values. +* + I = IDAMAX( N, D, 1 ) + SMAX = ABS( D( I ) ) + I = IDAMAX( N-1, E, 1 ) + SMAX = MAX( SMAX, ABS( E( I ) ) ) +* +* Compute threshold for neglecting D's and E's. +* + SMIN = ABS( D( 1 ) ) + IF( SMIN.NE.ZERO ) THEN + MU = SMIN + DO I = 2, N + MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) ) + SMIN = MIN( SMIN, MU ) + IF( SMIN.EQ.ZERO ) EXIT + END DO + END IF + SMIN = SMIN / SQRT( DBLE( N ) ) + THRESH = TOL*SMIN +* +* Check for zeros in D and E (splits), i.e. submatrices. +* + DO I = 1, N-1 + IF( ABS( D( I ) ).LE.THRESH ) D( I ) = ZERO + IF( ABS( E( I ) ).LE.THRESH ) E( I ) = ZERO + END DO + IF( ABS( D( N ) ).LE.THRESH ) D( N ) = ZERO +* +* Pointers for arrays used by DSTEVX. +* + IDTGK = 1 + IETGK = IDTGK + N*2 + ITEMP = IETGK + N*2 + IIFAIL = 1 + IIWORK = IIFAIL + N*2 +* +* Set RNGVX, which corresponds to RANGE for DSTEVX in TGK mode. +* VL,VU or IL,IU are redefined to conform to implementation a) +* described in the leading comments. +* + ILTGK = 0 + IUTGK = 0 + VLTGK = ZERO + VUTGK = ZERO +* + IF( ALLSV ) THEN +* +* All singular values will be found. We aim at -s (see +* leading comments) with RNGVX = 'I'. IL and IU are set +* later (as ILTGK and IUTGK) according to the dimension +* of the active submatrix. +* + RNGVX = 'I' + IF( WANTZ ) CALL DLASET( 'F', N*2, N+1, ZERO, ZERO, Z, LDZ ) + ELSE IF( VALSV ) THEN +* +* Find singular values in a half-open interval. We aim +* at -s (see leading comments) and we swap VL and VU +* (as VUTGK and VLTGK), changing their signs. +* + RNGVX = 'V' + VLTGK = -VU + VUTGK = -VL + WORK( IDTGK:IDTGK+2*N-1 ) = ZERO + CALL DCOPY( N, D, 1, WORK( IETGK ), 2 ) + CALL DCOPY( N-1, E, 1, WORK( IETGK+1 ), 2 ) + CALL DSTEVX( 'N', 'V', N*2, WORK( IDTGK ), WORK( IETGK ), + $ VLTGK, VUTGK, ILTGK, ILTGK, ABSTOL, NS, S, + $ Z, LDZ, WORK( ITEMP ), IWORK( IIWORK ), + $ IWORK( IIFAIL ), INFO ) + IF( NS.EQ.0 ) THEN + RETURN + ELSE + IF( WANTZ ) CALL DLASET( 'F', N*2, NS, ZERO, ZERO, Z, LDZ ) + END IF + ELSE IF( INDSV ) THEN +* +* Find the IL-th through the IU-th singular values. We aim +* at -s (see leading comments) and indices are mapped into +* values, therefore mimicking DSTEBZ, where +* +* GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN +* GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN +* + ILTGK = IL + IUTGK = IU + RNGVX = 'V' + WORK( IDTGK:IDTGK+2*N-1 ) = ZERO + CALL DCOPY( N, D, 1, WORK( IETGK ), 2 ) + CALL DCOPY( N-1, E, 1, WORK( IETGK+1 ), 2 ) + CALL DSTEVX( 'N', 'I', N*2, WORK( IDTGK ), WORK( IETGK ), + $ VLTGK, VLTGK, ILTGK, ILTGK, ABSTOL, NS, S, + $ Z, LDZ, WORK( ITEMP ), IWORK( IIWORK ), + $ IWORK( IIFAIL ), INFO ) + VLTGK = S( 1 ) - FUDGE*SMAX*ULP*N + WORK( IDTGK:IDTGK+2*N-1 ) = ZERO + CALL DCOPY( N, D, 1, WORK( IETGK ), 2 ) + CALL DCOPY( N-1, E, 1, WORK( IETGK+1 ), 2 ) + CALL DSTEVX( 'N', 'I', N*2, WORK( IDTGK ), WORK( IETGK ), + $ VUTGK, VUTGK, IUTGK, IUTGK, ABSTOL, NS, S, + $ Z, LDZ, WORK( ITEMP ), IWORK( IIWORK ), + $ IWORK( IIFAIL ), INFO ) + VUTGK = S( 1 ) + FUDGE*SMAX*ULP*N + VUTGK = MIN( VUTGK, ZERO ) +* +* If VLTGK=VUTGK, DSTEVX returns an error message, +* so if needed we change VUTGK slightly. +* + IF( VLTGK.EQ.VUTGK ) VLTGK = VLTGK - TOL +* + IF( WANTZ ) CALL DLASET( 'F', N*2, IU-IL+1, ZERO, ZERO, Z, LDZ) + END IF +* +* Initialize variables and pointers for S, Z, and WORK. +* +* NRU, NRV: number of rows in U and V for the active submatrix +* IDBEG, ISBEG: offsets for the entries of D and S +* IROWZ, ICOLZ: offsets for the rows and columns of Z +* IROWU, IROWV: offsets for the rows of U and V +* + NS = 0 + NRU = 0 + NRV = 0 + IDBEG = 1 + ISBEG = 1 + IROWZ = 1 + ICOLZ = 1 + IROWU = 2 + IROWV = 1 + SPLIT = .FALSE. + SVEQ0 = .FALSE. +* +* Form the tridiagonal TGK matrix. +* + S( 1:N ) = ZERO + WORK( IETGK+2*N-1 ) = ZERO + WORK( IDTGK:IDTGK+2*N-1 ) = ZERO + CALL DCOPY( N, D, 1, WORK( IETGK ), 2 ) + CALL DCOPY( N-1, E, 1, WORK( IETGK+1 ), 2 ) +* +* +* Check for splits in two levels, outer level +* in E and inner level in D. +* + DO IEPTR = 2, N*2, 2 + IF( WORK( IETGK+IEPTR-1 ).EQ.ZERO ) THEN +* +* Split in E (this piece of B is square) or bottom +* of the (input bidiagonal) matrix. +* + ISPLT = IDBEG + IDEND = IEPTR - 1 + DO IDPTR = IDBEG, IDEND, 2 + IF( WORK( IETGK+IDPTR-1 ).EQ.ZERO ) THEN +* +* Split in D (rectangular submatrix). Set the number +* of rows in U and V (NRU and NRV) accordingly. +* + IF( IDPTR.EQ.IDBEG ) THEN +* +* D=0 at the top. +* + SVEQ0 = .TRUE. + IF( IDBEG.EQ.IDEND) THEN + NRU = 1 + NRV = 1 + END IF + ELSE IF( IDPTR.EQ.IDEND ) THEN +* +* D=0 at the bottom. +* + SVEQ0 = .TRUE. + NRU = (IDEND-ISPLT)/2 + 1 + NRV = NRU + IF( ISPLT.NE.IDBEG ) THEN + NRU = NRU + 1 + END IF + ELSE + IF( ISPLT.EQ.IDBEG ) THEN +* +* Split: top rectangular submatrix. +* + NRU = (IDPTR-IDBEG)/2 + NRV = NRU + 1 + ELSE +* +* Split: middle square submatrix. +* + NRU = (IDPTR-ISPLT)/2 + 1 + NRV = NRU + END IF + END IF + ELSE IF( IDPTR.EQ.IDEND ) THEN +* +* Last entry of D in the active submatrix. +* + IF( ISPLT.EQ.IDBEG ) THEN +* +* No split (trivial case). +* + NRU = (IDEND-IDBEG)/2 + 1 + NRV = NRU + ELSE +* +* Split: bottom rectangular submatrix. +* + NRV = (IDEND-ISPLT)/2 + 1 + NRU = NRV + 1 + END IF + END IF +* + NTGK = NRU + NRV +* + IF( NTGK.GT.0 ) THEN +* +* Compute eigenvalues/vectors of the active +* submatrix according to RANGE: +* if RANGE='A' (ALLSV) then RNGVX = 'I' +* if RANGE='V' (VALSV) then RNGVX = 'V' +* if RANGE='I' (INDSV) then RNGVX = 'V' +* + ILTGK = 1 + IUTGK = NTGK / 2 + IF( ALLSV .OR. VUTGK.EQ.ZERO ) THEN + IF( SVEQ0 .OR. + $ SMIN.LT.EPS .OR. + $ MOD(NTGK,2).GT.0 ) THEN +* Special case: eigenvalue equal to zero or very +* small, additional eigenvector is needed. + IUTGK = IUTGK + 1 + END IF + END IF +* +* Workspace needed by DSTEVX: +* WORK( ITEMP: ): 2*5*NTGK +* IWORK( 1: ): 2*6*NTGK +* + CALL DSTEVX( JOBZ, RNGVX, NTGK, WORK( IDTGK+ISPLT-1 ), + $ WORK( IETGK+ISPLT-1 ), VLTGK, VUTGK, + $ ILTGK, IUTGK, ABSTOL, NSL, S( ISBEG ), + $ Z( IROWZ,ICOLZ ), LDZ, WORK( ITEMP ), + $ IWORK( IIWORK ), IWORK( IIFAIL ), + $ INFO ) + IF( INFO.NE.0 ) THEN +* Exit with the error code from DSTEVX. + RETURN + END IF + EMIN = ABS( MAXVAL( S( ISBEG:ISBEG+NSL-1 ) ) ) +* + IF( NSL.GT.0 .AND. WANTZ ) THEN +* +* Normalize u=Z([2,4,...],:) and v=Z([1,3,...],:), +* changing the sign of v as discussed in the leading +* comments. The norms of u and v may be (slightly) +* different from 1/sqrt(2) if the corresponding +* eigenvalues are very small or too close. We check +* those norms and, if needed, reorthogonalize the +* vectors. +* + IF( NSL.GT.1 .AND. + $ VUTGK.EQ.ZERO .AND. + $ MOD(NTGK,2).EQ.0 .AND. + $ EMIN.EQ.0 .AND. .NOT.SPLIT ) THEN +* +* D=0 at the top or bottom of the active submatrix: +* one eigenvalue is equal to zero; concatenate the +* eigenvectors corresponding to the two smallest +* eigenvalues. +* + Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-2 ) = + $ Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-2 ) + + $ Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-1 ) + Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-1 ) = + $ ZERO +* IF( IUTGK*2.GT.NTGK ) THEN +* Eigenvalue equal to zero or very small. +* NSL = NSL - 1 +* END IF + END IF +* + DO I = 0, MIN( NSL-1, NRU-1 ) + NRMU = DNRM2( NRU, Z( IROWU, ICOLZ+I ), 2 ) + IF( NRMU.EQ.ZERO ) THEN + INFO = N*2 + 1 + RETURN + END IF + CALL DSCAL( NRU, ONE/NRMU, + $ Z( IROWU,ICOLZ+I ), 2 ) + IF( NRMU.NE.ONE .AND. + $ ABS( NRMU-ORTOL )*SQRT2.GT.ONE ) + $ THEN + DO J = 0, I-1 + ZJTJI = -DDOT( NRU, Z( IROWU, ICOLZ+J ), + $ 2, Z( IROWU, ICOLZ+I ), 2 ) + CALL DAXPY( NRU, ZJTJI, + $ Z( IROWU, ICOLZ+J ), 2, + $ Z( IROWU, ICOLZ+I ), 2 ) + END DO + NRMU = DNRM2( NRU, Z( IROWU, ICOLZ+I ), 2 ) + CALL DSCAL( NRU, ONE/NRMU, + $ Z( IROWU,ICOLZ+I ), 2 ) + END IF + END DO + DO I = 0, MIN( NSL-1, NRV-1 ) + NRMV = DNRM2( NRV, Z( IROWV, ICOLZ+I ), 2 ) + IF( NRMV.EQ.ZERO ) THEN + INFO = N*2 + 1 + RETURN + END IF + CALL DSCAL( NRV, -ONE/NRMV, + $ Z( IROWV,ICOLZ+I ), 2 ) + IF( NRMV.NE.ONE .AND. + $ ABS( NRMV-ORTOL )*SQRT2.GT.ONE ) + $ THEN + DO J = 0, I-1 + ZJTJI = -DDOT( NRV, Z( IROWV, ICOLZ+J ), + $ 2, Z( IROWV, ICOLZ+I ), 2 ) + CALL DAXPY( NRU, ZJTJI, + $ Z( IROWV, ICOLZ+J ), 2, + $ Z( IROWV, ICOLZ+I ), 2 ) + END DO + NRMV = DNRM2( NRV, Z( IROWV, ICOLZ+I ), 2 ) + CALL DSCAL( NRV, ONE/NRMV, + $ Z( IROWV,ICOLZ+I ), 2 ) + END IF + END DO + IF( VUTGK.EQ.ZERO .AND. + $ IDPTR.LT.IDEND .AND. + $ MOD(NTGK,2).GT.0 ) THEN +* +* D=0 in the middle of the active submatrix (one +* eigenvalue is equal to zero): save the corresponding +* eigenvector for later use (when bottom of the +* active submatrix is reached). +* + SPLIT = .TRUE. + Z( IROWZ:IROWZ+NTGK-1,N+1 ) = + $ Z( IROWZ:IROWZ+NTGK-1,NS+NSL ) + Z( IROWZ:IROWZ+NTGK-1,NS+NSL ) = + $ ZERO + END IF + END IF !** WANTZ **! +* + NSL = MIN( NSL, NRU ) + SVEQ0 = .FALSE. +* +* Absolute values of the eigenvalues of TGK. +* + DO I = 0, NSL-1 + S( ISBEG+I ) = ABS( S( ISBEG+I ) ) + END DO +* +* Update pointers for TGK, S and Z. +* + ISBEG = ISBEG + NSL + IROWZ = IROWZ + NTGK + ICOLZ = ICOLZ + NSL + IROWU = IROWZ + IROWV = IROWZ + 1 + ISPLT = IDPTR + 1 + NS = NS + NSL + NRU = 0 + NRV = 0 + END IF !** NTGK.GT.0 **! + IF( IROWZ.LT.N*2 .AND. WANTZ ) THEN + Z( 1:IROWZ-1, ICOLZ ) = ZERO + END IF + END DO !** IDPTR loop **! + IF( SPLIT .AND. WANTZ ) THEN +* +* Bring back eigenvector corresponding +* to eigenvalue equal to zero. +* + Z( IDBEG:IDEND-NTGK+1,ISBEG-1 ) = + $ Z( IDBEG:IDEND-NTGK+1,ISBEG-1 ) + + $ Z( IDBEG:IDEND-NTGK+1,N+1 ) + Z( IDBEG:IDEND-NTGK+1,N+1 ) = 0 + END IF + IROWV = IROWV - 1 + IROWU = IROWU + 1 + IDBEG = IEPTR + 1 + SVEQ0 = .FALSE. + SPLIT = .FALSE. + END IF !** Check for split in E **! + END DO !** IEPTR loop **! +* +* Sort the singular values into decreasing order (insertion sort on +* singular values, but only one transposition per singular vector) +* + DO I = 1, NS-1 + K = 1 + SMIN = S( 1 ) + DO J = 2, NS + 1 - I + IF( S( J ).LE.SMIN ) THEN + K = J + SMIN = S( J ) + END IF + END DO + IF( K.NE.NS+1-I ) THEN + S( K ) = S( NS+1-I ) + S( NS+1-I ) = SMIN + IF( WANTZ ) CALL DSWAP( N*2, Z( 1,K ), 1, Z( 1,NS+1-I ), 1 ) + END IF + END DO +* +* If RANGE=I, check for singular values/vectors to be discarded. +* + IF( INDSV ) THEN + K = IU - IL + 1 + IF( K.LT.NS ) THEN + S( K+1:NS ) = ZERO + IF( WANTZ ) Z( 1:N*2,K+1:NS ) = ZERO + NS = K + END IF + END IF +* +* Reorder Z: U = Z( 1:N,1:NS ), V = Z( N+1:N*2,1:NS ). +* If B is a lower diagonal, swap U and V. +* + IF( WANTZ ) THEN + DO I = 1, NS + CALL DCOPY( N*2, Z( 1,I ), 1, WORK, 1 ) + IF( LOWER ) THEN + CALL DCOPY( N, WORK( 2 ), 2, Z( N+1,I ), 1 ) + CALL DCOPY( N, WORK( 1 ), 2, Z( 1 ,I ), 1 ) + ELSE + CALL DCOPY( N, WORK( 2 ), 2, Z( 1 ,I ), 1 ) + CALL DCOPY( N, WORK( 1 ), 2, Z( N+1,I ), 1 ) + END IF + END DO + END IF +* + RETURN +* +* End of DBDSVDX +* + END diff --git a/math/lapack/src/main/fortran/ddisna.f b/math/lapack/src/main/fortran/ddisna.f new file mode 100644 index 0000000000..61345c6e7a --- /dev/null +++ b/math/lapack/src/main/fortran/ddisna.f @@ -0,0 +1,245 @@ +*> \brief \b DDISNA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DDISNA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOB +* INTEGER INFO, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), SEP( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DDISNA computes the reciprocal condition numbers for the eigenvectors +*> of a real symmetric or complex Hermitian matrix or for the left or +*> right singular vectors of a general m-by-n matrix. The reciprocal +*> condition number is the 'gap' between the corresponding eigenvalue or +*> singular value and the nearest other one. +*> +*> The bound on the error, measured by angle in radians, in the I-th +*> computed vector is given by +*> +*> DLAMCH( 'E' ) * ( ANORM / SEP( I ) ) +*> +*> where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed +*> to be smaller than DLAMCH( 'E' )*ANORM in order to limit the size of +*> the error bound. +*> +*> DDISNA may also be used to compute error bounds for eigenvectors of +*> the generalized symmetric definite eigenproblem. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is CHARACTER*1 +*> Specifies for which problem the reciprocal condition numbers +*> should be computed: +*> = 'E': the eigenvectors of a symmetric/Hermitian matrix; +*> = 'L': the left singular vectors of a general matrix; +*> = 'R': the right singular vectors of a general matrix. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> If JOB = 'L' or 'R', the number of columns of the matrix, +*> in which case N >= 0. Ignored if JOB = 'E'. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (M) if JOB = 'E' +*> dimension (min(M,N)) if JOB = 'L' or 'R' +*> The eigenvalues (if JOB = 'E') or singular values (if JOB = +*> 'L' or 'R') of the matrix, in either increasing or decreasing +*> order. If singular values, they must be non-negative. +*> \endverbatim +*> +*> \param[out] SEP +*> \verbatim +*> SEP is DOUBLE PRECISION array, dimension (M) if JOB = 'E' +*> dimension (min(M,N)) if JOB = 'L' or 'R' +*> The reciprocal condition numbers of the vectors. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), SEP( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL DECR, EIGEN, INCR, LEFT, RIGHT, SING + INTEGER I, K + DOUBLE PRECISION ANORM, EPS, NEWGAP, OLDGAP, SAFMIN, THRESH +* .. +* .. 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 + EIGEN = LSAME( JOB, 'E' ) + LEFT = LSAME( JOB, 'L' ) + RIGHT = LSAME( JOB, 'R' ) + SING = LEFT .OR. RIGHT + IF( EIGEN ) THEN + K = M + ELSE IF( SING ) THEN + K = MIN( M, N ) + END IF + IF( .NOT.EIGEN .AND. .NOT.SING ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( K.LT.0 ) THEN + INFO = -3 + ELSE + INCR = .TRUE. + DECR = .TRUE. + DO 10 I = 1, K - 1 + IF( INCR ) + $ INCR = INCR .AND. D( I ).LE.D( I+1 ) + IF( DECR ) + $ DECR = DECR .AND. D( I ).GE.D( I+1 ) + 10 CONTINUE + IF( SING .AND. K.GT.0 ) THEN + IF( INCR ) + $ INCR = INCR .AND. ZERO.LE.D( 1 ) + IF( DECR ) + $ DECR = DECR .AND. D( K ).GE.ZERO + END IF + IF( .NOT.( INCR .OR. DECR ) ) + $ INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DDISNA', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( K.EQ.0 ) + $ RETURN +* +* Compute reciprocal condition numbers +* + IF( K.EQ.1 ) THEN + SEP( 1 ) = DLAMCH( 'O' ) + ELSE + OLDGAP = ABS( D( 2 )-D( 1 ) ) + SEP( 1 ) = OLDGAP + DO 20 I = 2, K - 1 + NEWGAP = ABS( D( I+1 )-D( I ) ) + SEP( I ) = MIN( OLDGAP, NEWGAP ) + OLDGAP = NEWGAP + 20 CONTINUE + SEP( K ) = OLDGAP + END IF + IF( SING ) THEN + IF( ( LEFT .AND. M.GT.N ) .OR. ( RIGHT .AND. M.LT.N ) ) THEN + IF( INCR ) + $ SEP( 1 ) = MIN( SEP( 1 ), D( 1 ) ) + IF( DECR ) + $ SEP( K ) = MIN( SEP( K ), D( K ) ) + END IF + END IF +* +* Ensure that reciprocal condition numbers are not less than +* threshold, in order to limit the size of the error bound +* + EPS = DLAMCH( 'E' ) + SAFMIN = DLAMCH( 'S' ) + ANORM = MAX( ABS( D( 1 ) ), ABS( D( K ) ) ) + IF( ANORM.EQ.ZERO ) THEN + THRESH = EPS + ELSE + THRESH = MAX( EPS*ANORM, SAFMIN ) + END IF + DO 30 I = 1, K + SEP( I ) = MAX( SEP( I ), THRESH ) + 30 CONTINUE +* + RETURN +* +* End of DDISNA +* + END diff --git a/math/lapack/src/main/fortran/dgbbrd.f b/math/lapack/src/main/fortran/dgbbrd.f new file mode 100644 index 0000000000..350a982fb5 --- /dev/null +++ b/math/lapack/src/main/fortran/dgbbrd.f @@ -0,0 +1,547 @@ +*> \brief \b DGBBRD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGBBRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, +* LDQ, PT, LDPT, C, LDC, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER VECT +* INTEGER INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), C( LDC, * ), D( * ), E( * ), +* $ PT( LDPT, * ), Q( LDQ, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGBBRD reduces a real general m-by-n band matrix A to upper +*> bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. +*> +*> The routine computes B, and optionally forms Q or P**T, or computes +*> Q**T*C for a given matrix C. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] VECT +*> \verbatim +*> VECT is CHARACTER*1 +*> Specifies whether or not the matrices Q and P**T are to be +*> formed. +*> = 'N': do not form Q or P**T; +*> = 'Q': form Q only; +*> = 'P': form P**T only; +*> = 'B': form both. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NCC +*> \verbatim +*> NCC is INTEGER +*> The number of columns of the matrix C. NCC >= 0. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals of the matrix A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals of the matrix A. KU >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the m-by-n band matrix A, stored in rows 1 to +*> KL+KU+1. The j-th column of A is stored in the j-th column of +*> the array AB as follows: +*> AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). +*> On exit, A is overwritten by values generated during the +*> reduction. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array A. LDAB >= KL+KU+1. +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (min(M,N)) +*> The diagonal elements of the bidiagonal matrix B. +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (min(M,N)-1) +*> The superdiagonal elements of the bidiagonal matrix B. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ,M) +*> If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q. +*> If VECT = 'N' or 'P', the array Q is not referenced. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. +*> LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. +*> \endverbatim +*> +*> \param[out] PT +*> \verbatim +*> PT is DOUBLE PRECISION array, dimension (LDPT,N) +*> If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'. +*> If VECT = 'N' or 'Q', the array PT is not referenced. +*> \endverbatim +*> +*> \param[in] LDPT +*> \verbatim +*> LDPT is INTEGER +*> The leading dimension of the array PT. +*> LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,NCC) +*> On entry, an m-by-ncc matrix C. +*> On exit, C is overwritten by Q**T*C. +*> C is not referenced if NCC = 0. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. +*> LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*max(M,N)) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBcomputational +* +* ===================================================================== + SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, + $ LDQ, PT, LDPT, C, LDC, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER VECT + INTEGER INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), C( LDC, * ), D( * ), E( * ), + $ PT( LDPT, * ), Q( LDQ, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL WANTB, WANTC, WANTPT, WANTQ + INTEGER I, INCA, J, J1, J2, KB, KB1, KK, KLM, KLU1, + $ KUN, L, MINMN, ML, ML0, MN, MU, MU0, NR, NRT + DOUBLE PRECISION RA, RB, RC, RS +* .. +* .. External Subroutines .. + EXTERNAL DLARGV, DLARTG, DLARTV, DLASET, DROT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + WANTB = LSAME( VECT, 'B' ) + WANTQ = LSAME( VECT, 'Q' ) .OR. WANTB + WANTPT = LSAME( VECT, 'P' ) .OR. WANTB + WANTC = NCC.GT.0 + KLU1 = KL + KU + 1 + INFO = 0 + IF( .NOT.WANTQ .AND. .NOT.WANTPT .AND. .NOT.LSAME( VECT, 'N' ) ) + $ THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NCC.LT.0 ) THEN + INFO = -4 + ELSE IF( KL.LT.0 ) THEN + INFO = -5 + ELSE IF( KU.LT.0 ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KLU1 ) THEN + INFO = -8 + ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.MAX( 1, M ) ) THEN + INFO = -12 + ELSE IF( LDPT.LT.1 .OR. WANTPT .AND. LDPT.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDC.LT.1 .OR. WANTC .AND. LDC.LT.MAX( 1, M ) ) THEN + INFO = -16 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGBBRD', -INFO ) + RETURN + END IF +* +* Initialize Q and P**T to the unit matrix, if needed +* + IF( WANTQ ) + $ CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ ) + IF( WANTPT ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, PT, LDPT ) +* +* Quick return if possible. +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* + MINMN = MIN( M, N ) +* + IF( KL+KU.GT.1 ) THEN +* +* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce +* first to lower bidiagonal form and then transform to upper +* bidiagonal +* + IF( KU.GT.0 ) THEN + ML0 = 1 + MU0 = 2 + ELSE + ML0 = 2 + MU0 = 1 + END IF +* +* Wherever possible, plane rotations are generated and applied in +* vector operations of length NR over the index set J1:J2:KLU1. +* +* The sines of the plane rotations are stored in WORK(1:max(m,n)) +* and the cosines in WORK(max(m,n)+1:2*max(m,n)). +* + MN = MAX( M, N ) + KLM = MIN( M-1, KL ) + KUN = MIN( N-1, KU ) + KB = KLM + KUN + KB1 = KB + 1 + INCA = KB1*LDAB + NR = 0 + J1 = KLM + 2 + J2 = 1 - KUN +* + DO 90 I = 1, MINMN +* +* Reduce i-th column and i-th row of matrix to bidiagonal form +* + ML = KLM + 1 + MU = KUN + 1 + DO 80 KK = 1, KB + J1 = J1 + KB + J2 = J2 + KB +* +* generate plane rotations to annihilate nonzero elements +* which have been created below the band +* + IF( NR.GT.0 ) + $ CALL DLARGV( NR, AB( KLU1, J1-KLM-1 ), INCA, + $ WORK( J1 ), KB1, WORK( MN+J1 ), KB1 ) +* +* apply plane rotations from the left +* + DO 10 L = 1, KB + IF( J2-KLM+L-1.GT.N ) THEN + NRT = NR - 1 + ELSE + NRT = NR + END IF + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( KLU1-L, J1-KLM+L-1 ), INCA, + $ AB( KLU1-L+1, J1-KLM+L-1 ), INCA, + $ WORK( MN+J1 ), WORK( J1 ), KB1 ) + 10 CONTINUE +* + IF( ML.GT.ML0 ) THEN + IF( ML.LE.M-I+1 ) THEN +* +* generate plane rotation to annihilate a(i+ml-1,i) +* within the band, and apply rotation from the left +* + CALL DLARTG( AB( KU+ML-1, I ), AB( KU+ML, I ), + $ WORK( MN+I+ML-1 ), WORK( I+ML-1 ), + $ RA ) + AB( KU+ML-1, I ) = RA + IF( I.LT.N ) + $ CALL DROT( MIN( KU+ML-2, N-I ), + $ AB( KU+ML-2, I+1 ), LDAB-1, + $ AB( KU+ML-1, I+1 ), LDAB-1, + $ WORK( MN+I+ML-1 ), WORK( I+ML-1 ) ) + END IF + NR = NR + 1 + J1 = J1 - KB1 + END IF +* + IF( WANTQ ) THEN +* +* accumulate product of plane rotations in Q +* + DO 20 J = J1, J2, KB1 + CALL DROT( M, Q( 1, J-1 ), 1, Q( 1, J ), 1, + $ WORK( MN+J ), WORK( J ) ) + 20 CONTINUE + END IF +* + IF( WANTC ) THEN +* +* apply plane rotations to C +* + DO 30 J = J1, J2, KB1 + CALL DROT( NCC, C( J-1, 1 ), LDC, C( J, 1 ), LDC, + $ WORK( MN+J ), WORK( J ) ) + 30 CONTINUE + END IF +* + IF( J2+KUN.GT.N ) THEN +* +* adjust J2 to keep within the bounds of the matrix +* + NR = NR - 1 + J2 = J2 - KB1 + END IF +* + DO 40 J = J1, J2, KB1 +* +* create nonzero element a(j-1,j+ku) above the band +* and store it in WORK(n+1:2*n) +* + WORK( J+KUN ) = WORK( J )*AB( 1, J+KUN ) + AB( 1, J+KUN ) = WORK( MN+J )*AB( 1, J+KUN ) + 40 CONTINUE +* +* generate plane rotations to annihilate nonzero elements +* which have been generated above the band +* + IF( NR.GT.0 ) + $ CALL DLARGV( NR, AB( 1, J1+KUN-1 ), INCA, + $ WORK( J1+KUN ), KB1, WORK( MN+J1+KUN ), + $ KB1 ) +* +* apply plane rotations from the right +* + DO 50 L = 1, KB + IF( J2+L-1.GT.M ) THEN + NRT = NR - 1 + ELSE + NRT = NR + END IF + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( L+1, J1+KUN-1 ), INCA, + $ AB( L, J1+KUN ), INCA, + $ WORK( MN+J1+KUN ), WORK( J1+KUN ), + $ KB1 ) + 50 CONTINUE +* + IF( ML.EQ.ML0 .AND. MU.GT.MU0 ) THEN + IF( MU.LE.N-I+1 ) THEN +* +* generate plane rotation to annihilate a(i,i+mu-1) +* within the band, and apply rotation from the right +* + CALL DLARTG( AB( KU-MU+3, I+MU-2 ), + $ AB( KU-MU+2, I+MU-1 ), + $ WORK( MN+I+MU-1 ), WORK( I+MU-1 ), + $ RA ) + AB( KU-MU+3, I+MU-2 ) = RA + CALL DROT( MIN( KL+MU-2, M-I ), + $ AB( KU-MU+4, I+MU-2 ), 1, + $ AB( KU-MU+3, I+MU-1 ), 1, + $ WORK( MN+I+MU-1 ), WORK( I+MU-1 ) ) + END IF + NR = NR + 1 + J1 = J1 - KB1 + END IF +* + IF( WANTPT ) THEN +* +* accumulate product of plane rotations in P**T +* + DO 60 J = J1, J2, KB1 + CALL DROT( N, PT( J+KUN-1, 1 ), LDPT, + $ PT( J+KUN, 1 ), LDPT, WORK( MN+J+KUN ), + $ WORK( J+KUN ) ) + 60 CONTINUE + END IF +* + IF( J2+KB.GT.M ) THEN +* +* adjust J2 to keep within the bounds of the matrix +* + NR = NR - 1 + J2 = J2 - KB1 + END IF +* + DO 70 J = J1, J2, KB1 +* +* create nonzero element a(j+kl+ku,j+ku-1) below the +* band and store it in WORK(1:n) +* + WORK( J+KB ) = WORK( J+KUN )*AB( KLU1, J+KUN ) + AB( KLU1, J+KUN ) = WORK( MN+J+KUN )*AB( KLU1, J+KUN ) + 70 CONTINUE +* + IF( ML.GT.ML0 ) THEN + ML = ML - 1 + ELSE + MU = MU - 1 + END IF + 80 CONTINUE + 90 CONTINUE + END IF +* + IF( KU.EQ.0 .AND. KL.GT.0 ) THEN +* +* A has been reduced to lower bidiagonal form +* +* Transform lower bidiagonal form to upper bidiagonal by applying +* plane rotations from the left, storing diagonal elements in D +* and off-diagonal elements in E +* + DO 100 I = 1, MIN( M-1, N ) + CALL DLARTG( AB( 1, I ), AB( 2, I ), RC, RS, RA ) + D( I ) = RA + IF( I.LT.N ) THEN + E( I ) = RS*AB( 1, I+1 ) + AB( 1, I+1 ) = RC*AB( 1, I+1 ) + END IF + IF( WANTQ ) + $ CALL DROT( M, Q( 1, I ), 1, Q( 1, I+1 ), 1, RC, RS ) + IF( WANTC ) + $ CALL DROT( NCC, C( I, 1 ), LDC, C( I+1, 1 ), LDC, RC, + $ RS ) + 100 CONTINUE + IF( M.LE.N ) + $ D( M ) = AB( 1, M ) + ELSE IF( KU.GT.0 ) THEN +* +* A has been reduced to upper bidiagonal form +* + IF( M.LT.N ) THEN +* +* Annihilate a(m,m+1) by applying plane rotations from the +* right, storing diagonal elements in D and off-diagonal +* elements in E +* + RB = AB( KU, M+1 ) + DO 110 I = M, 1, -1 + CALL DLARTG( AB( KU+1, I ), RB, RC, RS, RA ) + D( I ) = RA + IF( I.GT.1 ) THEN + RB = -RS*AB( KU, I ) + E( I-1 ) = RC*AB( KU, I ) + END IF + IF( WANTPT ) + $ CALL DROT( N, PT( I, 1 ), LDPT, PT( M+1, 1 ), LDPT, + $ RC, RS ) + 110 CONTINUE + ELSE +* +* Copy off-diagonal elements to E and diagonal elements to D +* + DO 120 I = 1, MINMN - 1 + E( I ) = AB( KU, I+1 ) + 120 CONTINUE + DO 130 I = 1, MINMN + D( I ) = AB( KU+1, I ) + 130 CONTINUE + END IF + ELSE +* +* A is diagonal. Set elements of E to zero and copy diagonal +* elements to D. +* + DO 140 I = 1, MINMN - 1 + E( I ) = ZERO + 140 CONTINUE + DO 150 I = 1, MINMN + D( I ) = AB( 1, I ) + 150 CONTINUE + END IF + RETURN +* +* End of DGBBRD +* + END diff --git a/math/lapack/src/main/fortran/dgbcon.f b/math/lapack/src/main/fortran/dgbcon.f new file mode 100644 index 0000000000..26f14fd64f --- /dev/null +++ b/math/lapack/src/main/fortran/dgbcon.f @@ -0,0 +1,311 @@ +*> \brief \b DGBCON +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGBCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER NORM +* INTEGER INFO, KL, KU, LDAB, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGBCON estimates the reciprocal of the condition number of a real +*> general band matrix A, in either the 1-norm or the infinity-norm, +*> using the LU factorization computed by DGBTRF. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as +*> RCOND = 1 / ( norm(A) * norm(inv(A)) ). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals within the band of A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals within the band of A. KU >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> Details of the LU factorization of the band matrix A, as +*> computed by DGBTRF. U is stored as an upper triangular band +*> matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and +*> the multipliers used during the factorization are stored in +*> rows KL+KU+2 to 2*KL+KU+1. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices; for 1 <= i <= N, row i of the matrix was +*> interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is 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. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(norm(A) * norm(inv(A))). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBcomputational +* +* ===================================================================== + SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, + $ WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER INFO, KL, KU, LDAB, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LNOTI, ONENRM + CHARACTER NORMIN + INTEGER IX, J, JP, KASE, KASE1, KD, LM + DOUBLE PRECISION AINVNM, SCALE, SMLNUM, T +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DLACN2, DLATBS, DRSCL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MIN +* .. +* .. 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( KL.LT.0 ) THEN + INFO = -3 + ELSE IF( KU.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN + INFO = -6 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGBCON', -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 + KD = KL + KU + 1 + LNOTI = KL.GT.0 + 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). +* + IF( LNOTI ) THEN + DO 20 J = 1, N - 1 + LM = MIN( KL, N-J ) + JP = IPIV( J ) + T = WORK( JP ) + IF( JP.NE.J ) THEN + WORK( JP ) = WORK( J ) + WORK( J ) = T + END IF + CALL DAXPY( LM, -T, AB( KD+1, J ), 1, WORK( J+1 ), 1 ) + 20 CONTINUE + END IF +* +* Multiply by inv(U). +* + CALL DLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, + $ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), + $ INFO ) + ELSE +* +* Multiply by inv(U**T). +* + CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, + $ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), + $ INFO ) +* +* Multiply by inv(L**T). +* + IF( LNOTI ) THEN + DO 30 J = N - 1, 1, -1 + LM = MIN( KL, N-J ) + WORK( J ) = WORK( J ) - DDOT( LM, AB( KD+1, J ), 1, + $ WORK( J+1 ), 1 ) + JP = IPIV( J ) + IF( JP.NE.J ) THEN + T = WORK( JP ) + WORK( JP ) = WORK( J ) + WORK( J ) = T + END IF + 30 CONTINUE + END IF + END IF +* +* Divide X by 1/SCALE if doing so will not cause overflow. +* + 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 40 + 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 +* + 40 CONTINUE + RETURN +* +* End of DGBCON +* + END diff --git a/math/lapack/src/main/fortran/dgbequ.f b/math/lapack/src/main/fortran/dgbequ.f new file mode 100644 index 0000000000..486c88de52 --- /dev/null +++ b/math/lapack/src/main/fortran/dgbequ.f @@ -0,0 +1,324 @@ +*> \brief \b DGBEQU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGBEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, +* AMAX, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, KL, KU, LDAB, M, N +* DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGBEQU computes row and column scalings intended to equilibrate an +*> M-by-N band matrix A and reduce its condition number. R returns the +*> row scale factors and C the column scale factors, chosen to try to +*> make the largest element in each row and column of the matrix B with +*> elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. +*> +*> R(i) and C(j) are restricted to be between SMLNUM = smallest safe +*> number and BIGNUM = largest safe number. Use of these scaling +*> factors is not guaranteed to reduce the condition number of A but +*> works well in practice. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals within the band of A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals within the band of A. KU >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> The band matrix A, stored in rows 1 to KL+KU+1. The j-th +*> column of A is stored in the j-th column of the array AB as +*> follows: +*> AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KL+KU+1. +*> \endverbatim +*> +*> \param[out] R +*> \verbatim +*> R is DOUBLE PRECISION array, dimension (M) +*> If INFO = 0, or INFO > M, R contains the row scale factors +*> for A. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, C contains the column scale factors for A. +*> \endverbatim +*> +*> \param[out] ROWCND +*> \verbatim +*> ROWCND is 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. +*> \endverbatim +*> +*> \param[out] COLCND +*> \verbatim +*> COLCND is 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. +*> \endverbatim +*> +*> \param[out] AMAX +*> \verbatim +*> AMAX is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, and i is +*> <= M: the i-th row of A is exactly zero +*> > M: the (i-M)-th column of A is exactly zero +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBcomputational +* +* ===================================================================== + SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, KL, KU, LDAB, M, N + DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, KD + DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM +* .. +* .. 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( KL.LT.0 ) THEN + INFO = -3 + ELSE IF( KU.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGBEQU', -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. +* + KD = KU + 1 + DO 30 J = 1, N + DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M ) + R( I ) = MAX( R( I ), ABS( AB( KD+I-J, J ) ) ) + 20 CONTINUE + 30 CONTINUE +* +* 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. +* + KD = KU + 1 + DO 90 J = 1, N + DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M ) + C( J ) = MAX( C( J ), ABS( AB( KD+I-J, J ) )*R( I ) ) + 80 CONTINUE + 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 DGBEQU +* + END diff --git a/math/lapack/src/main/fortran/dgbequb.f b/math/lapack/src/main/fortran/dgbequb.f new file mode 100644 index 0000000000..f7543aa0cb --- /dev/null +++ b/math/lapack/src/main/fortran/dgbequb.f @@ -0,0 +1,340 @@ +*> \brief \b DGBEQUB +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGBEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, +* AMAX, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, KL, KU, LDAB, M, N +* DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGBEQUB computes row and column scalings intended to equilibrate an +*> M-by-N matrix A and reduce its condition number. R returns the row +*> scale factors and C the column scale factors, chosen to try to make +*> the largest element in each row and column of the matrix B with +*> elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most +*> the radix. +*> +*> R(i) and C(j) are restricted to be a power of the radix between +*> SMLNUM = smallest safe number and BIGNUM = largest safe number. Use +*> of these scaling factors is not guaranteed to reduce the condition +*> number of A but works well in practice. +*> +*> This routine differs from DGEEQU by restricting the scaling factors +*> to a power of the radix. Barring over- and underflow, scaling by +*> these factors introduces no additional rounding errors. However, the +*> scaled entries' magnitudes are no longer approximately 1 but lie +*> between sqrt(radix) and 1/sqrt(radix). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals within the band of A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals within the band of A. KU >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the matrix A in band storage, in rows 1 to KL+KU+1. +*> The j-th column of A is stored in the j-th column of the +*> array AB as follows: +*> AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array A. LDAB >= max(1,M). +*> \endverbatim +*> +*> \param[out] R +*> \verbatim +*> R is DOUBLE PRECISION array, dimension (M) +*> If INFO = 0 or INFO > M, R contains the row scale factors +*> for A. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, C contains the column scale factors for A. +*> \endverbatim +*> +*> \param[out] ROWCND +*> \verbatim +*> ROWCND is 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. +*> \endverbatim +*> +*> \param[out] COLCND +*> \verbatim +*> COLCND is 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. +*> \endverbatim +*> +*> \param[out] AMAX +*> \verbatim +*> AMAX is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, and i is +*> <= M: the i-th row of A is exactly zero +*> > M: the (i-M)-th column of A is exactly zero +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBcomputational +* +* ===================================================================== + SUBROUTINE DGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, KL, KU, LDAB, M, N + DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, KD + DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM, RADIX, LOGRDX +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, LOG +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KL.LT.0 ) THEN + INFO = -3 + ELSE IF( KU.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGBEQUB', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + ROWCND = ONE + COLCND = ONE + AMAX = ZERO + RETURN + END IF +* +* Get machine constants. Assume SMLNUM is a power of the radix. +* + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + RADIX = DLAMCH( 'B' ) + LOGRDX = LOG(RADIX) +* +* Compute row scale factors. +* + DO 10 I = 1, M + R( I ) = ZERO + 10 CONTINUE +* +* Find the maximum element in each row. +* + KD = KU + 1 + DO 30 J = 1, N + DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M ) + R( I ) = MAX( R( I ), ABS( AB( KD+I-J, J ) ) ) + 20 CONTINUE + 30 CONTINUE + DO I = 1, M + IF( R( I ).GT.ZERO ) THEN + R( I ) = RADIX**INT( LOG( R( I ) ) / LOGRDX ) + END IF + END DO +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 40 I = 1, M + RCMAX = MAX( RCMAX, R( I ) ) + RCMIN = MIN( RCMIN, R( I ) ) + 40 CONTINUE + AMAX = RCMAX +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 50 I = 1, M + IF( R( I ).EQ.ZERO ) THEN + INFO = I + RETURN + END IF + 50 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 60 I = 1, M + R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) + 60 CONTINUE +* +* Compute ROWCND = min(R(I)) / max(R(I)). +* + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* +* Compute column scale factors. +* + DO 70 J = 1, N + C( J ) = ZERO + 70 CONTINUE +* +* Find the maximum element in each column, +* assuming the row scaling computed above. +* + DO 90 J = 1, N + DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M ) + C( J ) = MAX( C( J ), ABS( AB( KD+I-J, J ) )*R( I ) ) + 80 CONTINUE + IF( C( J ).GT.ZERO ) THEN + C( J ) = RADIX**INT( LOG( C( J ) ) / LOGRDX ) + END IF + 90 CONTINUE +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 100 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 100 CONTINUE +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 110 J = 1, N + IF( C( J ).EQ.ZERO ) THEN + INFO = M + J + RETURN + END IF + 110 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 120 J = 1, N + C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) + 120 CONTINUE +* +* Compute COLCND = min(C(J)) / max(C(J)). +* + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* + RETURN +* +* End of DGBEQUB +* + END diff --git a/math/lapack/src/main/fortran/dgbrfs.f b/math/lapack/src/main/fortran/dgbrfs.f new file mode 100644 index 0000000000..179ddfe572 --- /dev/null +++ b/math/lapack/src/main/fortran/dgbrfs.f @@ -0,0 +1,464 @@ +*> \brief \b DGBRFS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGBRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, +* IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), +* $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGBRFS improves the computed solution to a system of linear +*> equations when the coefficient matrix is banded, and provides +*> error bounds and backward error estimates for the solution. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals within the band of A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals within the band of A. KU >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> The original band matrix A, stored in rows 1 to KL+KU+1. +*> The j-th column of A is stored in the j-th column of the +*> array AB as follows: +*> AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KL+KU+1. +*> \endverbatim +*> +*> \param[in] AFB +*> \verbatim +*> AFB is DOUBLE PRECISION array, dimension (LDAFB,N) +*> Details of the LU factorization of the band matrix A, as +*> computed by DGBTRF. U is stored as an upper triangular band +*> matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and +*> the multipliers used during the factorization are stored in +*> rows KL+KU+2 to 2*KL+KU+1. +*> \endverbatim +*> +*> \param[in] LDAFB +*> \verbatim +*> LDAFB is INTEGER +*> The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from DGBTRF; for 1<=i<=N, row i of the +*> matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> On entry, the solution matrix X, as computed by DGBTRS. +*> On exit, the improved solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> ITMAX is the maximum number of steps of iterative refinement. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBcomputational +* +* ===================================================================== + SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, + $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. 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, KK, NZ + DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGBMV, DGBTRS, DLACN2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. 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( KL.LT.0 ) THEN + INFO = -3 + ELSE IF( KU.LT.0 ) THEN + INFO = -4 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -7 + ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGBRFS', -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 = MIN( KL+KU+2, 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 DGBMV( TRANS, N, N, KL, KU, -ONE, AB, LDAB, 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 + KK = KU + 1 - K + XK = ABS( X( K, J ) ) + DO 40 I = MAX( 1, K-KU ), MIN( N, K+KL ) + WORK( I ) = WORK( I ) + ABS( AB( KK+I, K ) )*XK + 40 CONTINUE + 50 CONTINUE + ELSE + DO 70 K = 1, N + S = ZERO + KK = KU + 1 - K + DO 60 I = MAX( 1, K-KU ), MIN( N, K+KL ) + S = S + ABS( AB( KK+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 DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, 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 DGBTRS( TRANST, N, KL, KU, 1, AFB, LDAFB, IPIV, + $ WORK( N+1 ), N, INFO ) + DO 110 I = 1, N + WORK( N+I ) = WORK( N+I )*WORK( I ) + 110 CONTINUE + ELSE +* +* Multiply by inv(op(A))*diag(W). +* + DO 120 I = 1, N + WORK( N+I ) = WORK( N+I )*WORK( I ) + 120 CONTINUE + CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, 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 DGBRFS +* + END diff --git a/math/lapack/src/main/fortran/dgbrfsx.f b/math/lapack/src/main/fortran/dgbrfsx.f new file mode 100644 index 0000000000..fb52d643ff --- /dev/null +++ b/math/lapack/src/main/fortran/dgbrfsx.f @@ -0,0 +1,765 @@ +*> \brief \b DGBRFSX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGBRFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, +* LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, +* BERR, N_ERR_BNDS, ERR_BNDS_NORM, +* ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS, EQUED +* INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS, +* $ NPARAMS, N_ERR_BNDS +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), +* $ X( LDX , * ),WORK( * ) +* DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), +* $ ERR_BNDS_NORM( NRHS, * ), +* $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGBRFSX improves the computed solution to a system of linear +*> equations and provides error bounds and backward error estimates +*> for the solution. In addition to normwise error bound, the code +*> provides maximum componentwise error bound if possible. See +*> comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the +*> error bounds. +*> +*> The original system of linear equations may have been equilibrated +*> before calling this routine, as described by arguments EQUED, R +*> and C below. In this case, the solution and error bounds returned +*> are for the original unequilibrated system. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> Some optional parameters are bundled in the PARAMS array. These +*> settings determine how refinement is performed, but often the +*> defaults are acceptable. If the defaults are acceptable, users +*> can pass NPARAMS = 0 which prevents the source code from accessing +*> the PARAMS argument. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] EQUED +*> \verbatim +*> EQUED is CHARACTER*1 +*> Specifies the form of equilibration that was done to A +*> before calling this routine. This is needed to compute +*> the solution and error bounds correctly. +*> = 'N': No equilibration +*> = 'R': Row equilibration, i.e., A has been premultiplied by +*> diag(R). +*> = 'C': Column equilibration, i.e., A has been postmultiplied +*> by diag(C). +*> = 'B': Both row and column equilibration, i.e., A has been +*> replaced by diag(R) * A * diag(C). +*> The right hand side B has been changed accordingly. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals within the band of A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals within the band of A. KU >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> The original band matrix A, stored in rows 1 to KL+KU+1. +*> The j-th column of A is stored in the j-th column of the +*> array AB as follows: +*> AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KL+KU+1. +*> \endverbatim +*> +*> \param[in] AFB +*> \verbatim +*> AFB is DOUBLE PRECISION array, dimension (LDAFB,N) +*> Details of the LU factorization of the band matrix A, as +*> computed by DGBTRF. U is stored as an upper triangular band +*> matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and +*> the multipliers used during the factorization are stored in +*> rows KL+KU+2 to 2*KL+KU+1. +*> \endverbatim +*> +*> \param[in] LDAFB +*> \verbatim +*> LDAFB is INTEGER +*> The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from DGETRF; for 1<=i<=N, row i of the +*> matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[in,out] R +*> \verbatim +*> R is DOUBLE PRECISION array, dimension (N) +*> The row scale factors for A. If EQUED = 'R' or 'B', A is +*> multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +*> is not accessed. R is an input argument if FACT = 'F'; +*> otherwise, R is an output argument. If FACT = 'F' and +*> EQUED = 'R' or 'B', each element of R must be positive. +*> If R is output, each element of R is a power of the radix. +*> If R is input, each element of R should be a power of the radix +*> to ensure a reliable solution and error estimates. Scaling by +*> powers of the radix does not cause rounding errors unless the +*> result underflows or overflows. Rounding errors during scaling +*> lead to refining with a matrix that is not equivalent to the +*> input matrix, producing error estimates that may not be +*> reliable. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> The column scale factors for A. If EQUED = 'C' or 'B', A is +*> multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +*> is not accessed. C is an input argument if FACT = 'F'; +*> otherwise, C is an output argument. If FACT = 'F' and +*> EQUED = 'C' or 'B', each element of C must be positive. +*> If C is output, each element of C is a power of the radix. +*> If C is input, each element of C should be a power of the radix +*> to ensure a reliable solution and error estimates. Scaling by +*> powers of the radix does not cause rounding errors unless the +*> result underflows or overflows. Rounding errors during scaling +*> lead to refining with a matrix that is not equivalent to the +*> input matrix, producing error estimates that may not be +*> reliable. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> On entry, the solution matrix X, as computed by DGETRS. +*> On exit, the improved solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> Reciprocal scaled condition number. This is an estimate of the +*> reciprocal Skeel condition number of the matrix A after +*> equilibration (if done). If this is less than the machine +*> precision (in particular, if it is zero), the matrix is singular +*> to working precision. Note that the error may still be small even +*> if this number is very small and the matrix appears ill- +*> conditioned. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is DOUBLE PRECISION array, dimension (NRHS) +*> Componentwise relative backward error. This is the +*> componentwise relative backward error of each solution vector X(j) +*> (i.e., the smallest relative change in any element of A or B that +*> makes X(j) an exact solution). +*> \endverbatim +*> +*> \param[in] N_ERR_BNDS +*> \verbatim +*> N_ERR_BNDS is INTEGER +*> Number of error bounds to return for each right hand side +*> and each type (normwise or componentwise). See ERR_BNDS_NORM and +*> ERR_BNDS_COMP below. +*> \endverbatim +*> +*> \param[out] ERR_BNDS_NORM +*> \verbatim +*> ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> normwise relative error, which is defined as follows: +*> +*> Normwise relative error in the ith solution vector: +*> max_j (abs(XTRUE(j,i) - X(j,i))) +*> ------------------------------ +*> max_j abs(X(j,i)) +*> +*> The array is indexed by the type of error information as described +*> below. There currently are up to three pieces of information +*> returned. +*> +*> The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_NORM(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * dlamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * dlamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated normwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * dlamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*A, where S scales each row by a power of the +*> radix so all absolute row sums of Z are approximately 1. +*> +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[out] ERR_BNDS_COMP +*> \verbatim +*> ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> componentwise relative error, which is defined as follows: +*> +*> Componentwise relative error in the ith solution vector: +*> abs(XTRUE(j,i) - X(j,i)) +*> max_j ---------------------- +*> abs(X(j,i)) +*> +*> The array is indexed by the right-hand side i (on which the +*> componentwise relative error depends), and the type of error +*> information as described below. There currently are up to three +*> pieces of information returned for each right-hand side. If +*> componentwise accuracy is not requested (PARAMS(3) = 0.0), then +*> ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +*> the first (:,N_ERR_BNDS) entries are returned. +*> +*> The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_COMP(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * dlamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * dlamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated componentwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * dlamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*(A*diag(x)), where x is the solution for the +*> current right-hand side and S scales each row of +*> A*diag(x) by a power of the radix so all absolute row +*> sums of Z are approximately 1. +*> +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[in] NPARAMS +*> \verbatim +*> NPARAMS is INTEGER +*> Specifies the number of parameters set in PARAMS. If .LE. 0, the +*> PARAMS array is never referenced and default values are used. +*> \endverbatim +*> +*> \param[in,out] PARAMS +*> \verbatim +*> PARAMS is DOUBLE PRECISION array, dimension (NPARAMS) +*> Specifies algorithm parameters. If an entry is .LT. 0.0, then +*> that entry will be filled with default value used for that +*> parameter. Only positions up to NPARAMS are accessed; defaults +*> are used for higher-numbered parameters. +*> +*> PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +*> refinement or not. +*> Default: 1.0D+0 +*> = 0.0 : No refinement is performed, and no error bounds are +*> computed. +*> = 1.0 : Use the double-precision refinement algorithm, +*> possibly with doubled-single computations if the +*> compilation environment does not support DOUBLE +*> PRECISION. +*> (other values are reserved for future use) +*> +*> PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +*> computations allowed for refinement. +*> Default: 10 +*> Aggressive: Set to 100 to permit convergence using approximate +*> factorizations or factorizations other than LU. If +*> the factorization uses a technique other than +*> Gaussian elimination, the guarantees in +*> err_bnds_norm and err_bnds_comp may no longer be +*> trustworthy. +*> +*> PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +*> will attempt to find a solution with small componentwise +*> relative error in the double-precision algorithm. Positive +*> is true, 0.0 is false. +*> Default: 1.0 (attempt componentwise convergence) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Successful exit. The solution to every right-hand side is +*> guaranteed. +*> < 0: If INFO = -i, the i-th argument had an illegal value +*> > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +*> has been completed, but the factor U is exactly singular, so +*> the solution and error bounds could not be computed. RCOND = 0 +*> is returned. +*> = N+J: The solution corresponding to the Jth right-hand side is +*> not guaranteed. The solutions corresponding to other right- +*> hand sides K with K > J may not be guaranteed as well, but +*> only the first such right-hand side is reported. If a small +*> componentwise error is not requested (PARAMS(3) = 0.0) then +*> the Jth right-hand side is the first with a normwise error +*> bound that is not guaranteed (the smallest J such +*> that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +*> the Jth right-hand side is the first with either a normwise or +*> componentwise error bound that is not guaranteed (the smallest +*> J such that either ERR_BNDS_NORM(J,1) = 0.0 or +*> ERR_BNDS_COMP(J,1) = 0.0). See the definition of +*> ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +*> about all of the right-hand sides check ERR_BNDS_NORM or +*> ERR_BNDS_COMP. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleGBcomputational +* +* ===================================================================== + SUBROUTINE DGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, + $ LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, + $ BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER TRANS, EQUED + INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS, + $ NPARAMS, N_ERR_BNDS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ X( LDX , * ),WORK( * ) + DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT + DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT + DOUBLE PRECISION DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0D+0 ) + PARAMETER ( ITHRESH_DEFAULT = 10.0D+0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0D+0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5D+0 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25D+0 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL ROWEQU, COLEQU, NOTRAN + INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + DOUBLE PRECISION ANORM, RCOND_TMP + DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DGBCON + EXTERNAL DLA_GBRFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, ILATRANS, ILAPREC + EXTERNAL DLAMCH, DLANGB, DLA_GBRCOND + DOUBLE PRECISION DLAMCH, DLANGB, DLA_GBRCOND + LOGICAL LSAME + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + TRANS_TYPE = ILATRANS( TRANS ) + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0D+0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = DBLE( N ) * DLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0D+0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0D+0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0D+0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0D+0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0D+0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0D+0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + NOTRAN = LSAME( TRANS, 'N' ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) +* +* Test input parameters. +* + IF( TRANS_TYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( .NOT.ROWEQU .AND. .NOT.COLEQU .AND. + $ .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KL.LT.0 ) THEN + INFO = -4 + ELSE IF( KU.LT.0 ) THEN + INFO = -5 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -8 + ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGBRFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0D+0 + DO J = 1, NRHS + BERR( J ) = 0.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF + IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0D+0 + END IF + IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0D+0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0D+0 + DO J = 1, NRHS + BERR( J ) = 1.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF + IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + END IF + IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0D+0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + IF( NOTRAN ) THEN + NORM = 'I' + ELSE + NORM = '1' + END IF + ANORM = DLANGB( NORM, N, KL, KU, AB, LDAB, WORK ) + CALL DGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND, + $ WORK, IWORK, INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 .AND. INFO .EQ. 0 ) THEN + + PREC_TYPE = ILAPREC( 'E' ) + + IF ( NOTRAN ) THEN + CALL DLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, + $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK( N+1 ), WORK( 1 ), WORK( 2*N+1 ), + $ WORK( 1 ), RCOND, ITHRESH, RTHRESH, UNSTABLE_THRESH, + $ IGNORE_CWISE, INFO ) + ELSE + CALL DLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, + $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, ROWEQU, R, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK( N+1 ), WORK( 1 ), WORK( 2*N+1 ), + $ WORK( 1 ), RCOND, ITHRESH, RTHRESH, UNSTABLE_THRESH, + $ IGNORE_CWISE, INFO ) + END IF + END IF + + ERR_LBND = MAX( 10.0D+0, SQRT( DBLE( N ) ) ) * DLAMCH( 'Epsilon' ) + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1 ) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( COLEQU .AND. NOTRAN ) THEN + RCOND_TMP = DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, -1, C, INFO, WORK, IWORK ) + ELSE IF ( ROWEQU .AND. .NOT. NOTRAN ) THEN + RCOND_TMP = DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, -1, R, INFO, WORK, IWORK ) + ELSE + RCOND_TMP = DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, 0, R, INFO, WORK, IWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF + + IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( DLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, 1, X( 1, J ), INFO, WORK, IWORK ) + ELSE + RCOND_TMP = 0.0D+0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0D+0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of DGBRFSX +* + END diff --git a/math/lapack/src/main/fortran/dgbsv.f b/math/lapack/src/main/fortran/dgbsv.f new file mode 100644 index 0000000000..b14fcaa5ac --- /dev/null +++ b/math/lapack/src/main/fortran/dgbsv.f @@ -0,0 +1,223 @@ +*> \brief DGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver) +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGBSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGBSV computes the solution to a real system of linear equations +*> A * X = B, where A is a band matrix of order N with KL subdiagonals +*> and KU superdiagonals, and X and B are N-by-NRHS matrices. +*> +*> The LU decomposition with partial pivoting and row interchanges is +*> used to factor A as A = L * U, where L is a product of permutation +*> and unit lower triangular matrices with KL subdiagonals, and U is +*> upper triangular with KL+KU superdiagonals. The factored form of A +*> is then used to solve the system of equations A * X = B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals within the band of A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals within the band of A. KU >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the matrix A in band storage, in rows KL+1 to +*> 2*KL+KU+1; rows 1 to KL of the array need not be set. +*> The j-th column of A is stored in the j-th column of the +*> array AB as follows: +*> AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL) +*> On exit, details of the factorization: U is stored as an +*> upper triangular band matrix with KL+KU superdiagonals in +*> rows 1 to KL+KU+1, and the multipliers used during the +*> factorization are stored in rows KL+KU+2 to 2*KL+KU+1. +*> See below for further details. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices that define the permutation matrix P; +*> row i of the matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization +*> has been completed, but the factor U is exactly +*> singular, and the solution has not been computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBsolve +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The band storage scheme is illustrated by the following example, when +*> M = N = 6, KL = 2, KU = 1: +*> +*> On entry: On exit: +*> +*> * * * + + + * * * u14 u25 u36 +*> * * + + + + * * u13 u24 u35 u46 +*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 +*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 +*> a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * +*> a31 a42 a53 a64 * * m31 m42 m53 m64 * * +*> +*> Array elements marked * are not used by the routine; elements marked +*> + need not be set on entry, but are required by the routine to store +*> elements of U because of fill-in resulting from the row interchanges. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. External Subroutines .. + EXTERNAL DGBTRF, DGBTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( KL.LT.0 ) THEN + INFO = -2 + ELSE IF( KU.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGBSV ', -INFO ) + RETURN + END IF +* +* Compute the LU factorization of the band matrix A. +* + CALL DGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL DGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV, + $ B, LDB, INFO ) + END IF + RETURN +* +* End of DGBSV +* + END diff --git a/math/lapack/src/main/fortran/dgbsvx.f b/math/lapack/src/main/fortran/dgbsvx.f new file mode 100644 index 0000000000..da4bf91036 --- /dev/null +++ b/math/lapack/src/main/fortran/dgbsvx.f @@ -0,0 +1,642 @@ +*> \brief DGBSVX computes the solution to system of linear equations A * X = B for GB matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGBSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, +* LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, +* RCOND, FERR, BERR, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER EQUED, FACT, TRANS +* INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), +* $ BERR( * ), C( * ), FERR( * ), R( * ), +* $ WORK( * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGBSVX uses the LU factorization to compute the solution to a real +*> system of linear equations A * X = B, A**T * X = B, or A**H * X = B, +*> where A is a band matrix of order N with KL subdiagonals and KU +*> superdiagonals, and X and B are N-by-NRHS matrices. +*> +*> Error bounds on the solution and a condition estimate are also +*> provided. +*> \endverbatim +* +*> \par Description: +* ================= +*> +*> \verbatim +*> +*> The following steps are performed by this subroutine: +*> +*> 1. If FACT = 'E', real scaling factors are computed to equilibrate +*> the system: +*> TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +*> TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +*> TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +*> Whether or not the system will be equilibrated depends on the +*> scaling of the matrix A, but if equilibration is used, A is +*> overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') +*> or diag(C)*B (if TRANS = 'T' or 'C'). +*> +*> 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the +*> matrix A (after equilibration if FACT = 'E') as +*> A = L * U, +*> where L is a product of permutation and unit lower triangular +*> matrices with KL subdiagonals, and U is upper triangular with +*> KL+KU superdiagonals. +*> +*> 3. If some U(i,i)=0, so that U is exactly singular, then the routine +*> returns with INFO = i. Otherwise, the factored form of A is used +*> to estimate the condition number of the matrix A. If the +*> reciprocal of the condition number is less than machine precision, +*> INFO = N+1 is returned as a warning, but the routine still goes on +*> to solve for X and compute error bounds as described below. +*> +*> 4. The system of equations is solved for X using the factored form +*> of A. +*> +*> 5. Iterative refinement is applied to improve the computed solution +*> matrix and calculate error bounds and backward error estimates +*> for it. +*> +*> 6. If equilibration was used, the matrix X is premultiplied by +*> diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so +*> that it solves the original system before equilibration. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> Specifies whether or not the factored form of the matrix A is +*> supplied on entry, and if not, whether the matrix A should be +*> equilibrated before it is factored. +*> = 'F': On entry, AFB and IPIV contain the factored form of +*> A. If EQUED is not 'N', the matrix A has been +*> equilibrated with scaling factors given by R and C. +*> AB, AFB, and IPIV are not modified. +*> = 'N': The matrix A will be copied to AFB and factored. +*> = 'E': The matrix A will be equilibrated if necessary, then +*> copied to AFB and factored. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals within the band of A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals within the band of A. KU >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the matrix A in band storage, in rows 1 to KL+KU+1. +*> The j-th column of A is stored in the j-th column of the +*> array AB as follows: +*> AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) +*> +*> If FACT = 'F' and EQUED is not 'N', then A must have been +*> equilibrated by the scaling factors in R and/or C. AB is not +*> modified if FACT = 'F' or 'N', or if FACT = 'E' and +*> EQUED = 'N' on exit. +*> +*> On exit, if EQUED .ne. 'N', A is scaled as follows: +*> EQUED = 'R': A := diag(R) * A +*> EQUED = 'C': A := A * diag(C) +*> EQUED = 'B': A := diag(R) * A * diag(C). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KL+KU+1. +*> \endverbatim +*> +*> \param[in,out] AFB +*> \verbatim +*> AFB is DOUBLE PRECISION array, dimension (LDAFB,N) +*> If FACT = 'F', then AFB is an input argument and on entry +*> contains details of the LU factorization of the band matrix +*> A, as computed by DGBTRF. U is stored as an upper triangular +*> band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, +*> and the multipliers used during the factorization are stored +*> in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is +*> the factored form of the equilibrated matrix A. +*> +*> If FACT = 'N', then AFB is an output argument and on exit +*> returns details of the LU factorization of A. +*> +*> If FACT = 'E', then AFB is an output argument and on exit +*> returns details of the LU factorization of the equilibrated +*> matrix A (see the description of AB for the form of the +*> equilibrated matrix). +*> \endverbatim +*> +*> \param[in] LDAFB +*> \verbatim +*> LDAFB is INTEGER +*> The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. +*> \endverbatim +*> +*> \param[in,out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> If FACT = 'F', then IPIV is an input argument and on entry +*> contains the pivot indices from the factorization A = L*U +*> as computed by DGBTRF; row i of the matrix was interchanged +*> with row IPIV(i). +*> +*> If FACT = 'N', then IPIV is an output argument and on exit +*> contains the pivot indices from the factorization A = L*U +*> of the original matrix A. +*> +*> If FACT = 'E', then IPIV is an output argument and on exit +*> contains the pivot indices from the factorization A = L*U +*> of the equilibrated matrix A. +*> \endverbatim +*> +*> \param[in,out] EQUED +*> \verbatim +*> EQUED is 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. +*> \endverbatim +*> +*> \param[in,out] R +*> \verbatim +*> R is 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. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is 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. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, +*> if EQUED = 'N', B is not modified; +*> if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by +*> diag(R)*B; +*> if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is +*> overwritten by diag(C)*B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is 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'. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is 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. +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> On exit, WORK(1) contains the reciprocal pivot growth +*> factor norm(A)/norm(U). The "max absolute element" norm is +*> used. If WORK(1) is much less than 1, then the stability +*> of the LU factorization of the (equilibrated) matrix A +*> could be poor. This also means that the solution X, condition +*> estimator RCOND, and forward error bound FERR could be +*> unreliable. If factorization fails with 0 WORK(1) contains the reciprocal pivot growth factor for the +*> leading INFO columns of A. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleGBsolve +* +* ===================================================================== + SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, + $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, + $ RCOND, FERR, BERR, WORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, TRANS + INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ BERR( * ), C( * ), FERR( * ), R( * ), + $ WORK( * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. 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, J1, J2 + DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN, + $ ROWCND, RPVGRW, SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGB, DLANTB + EXTERNAL LSAME, DLAMCH, DLANGB, DLANTB +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGBCON, DGBEQU, DGBRFS, DGBTRF, DGBTRS, + $ DLACPY, DLAQGB, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, 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( KL.LT.0 ) THEN + INFO = -4 + ELSE IF( KU.LT.0 ) THEN + INFO = -5 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -8 + ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN + INFO = -10 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -12 + ELSE + IF( ROWEQU ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 10 J = 1, N + RCMIN = MIN( RCMIN, R( J ) ) + RCMAX = MAX( RCMAX, R( J ) ) + 10 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -13 + ELSE IF( N.GT.0 ) THEN + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + ROWCND = ONE + END IF + END IF + IF( COLEQU .AND. INFO.EQ.0 ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 20 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 20 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -14 + ELSE IF( N.GT.0 ) THEN + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + COLCND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -18 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGBSVX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL DGBEQU( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL DLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, EQUED ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF + 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 the band matrix A. +* + DO 70 J = 1, N + J1 = MAX( J-KU, 1 ) + J2 = MIN( J+KL, N ) + CALL DCOPY( J2-J1+1, AB( KU+1-J+J1, J ), 1, + $ AFB( KL+KU+1-J+J1, J ), 1 ) + 70 CONTINUE +* + CALL DGBTRF( N, N, KL, KU, AFB, LDAFB, 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. +* + ANORM = ZERO + DO 90 J = 1, INFO + DO 80 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) + ANORM = MAX( ANORM, ABS( AB( I, J ) ) ) + 80 CONTINUE + 90 CONTINUE + RPVGRW = DLANTB( 'M', 'U', 'N', INFO, MIN( INFO-1, KL+KU ), + $ AFB( MAX( 1, KL+KU+2-INFO ), 1 ), LDAFB, + $ WORK ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = ANORM / 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 = DLANGB( NORM, N, KL, KU, AB, LDAB, WORK ) + RPVGRW = DLANTB( 'M', 'U', 'N', N, KL+KU, AFB, LDAFB, WORK ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = DLANGB( 'M', N, KL, KU, AB, LDAB, WORK ) / RPVGRW + END IF +* +* Compute the reciprocal of the condition number of A. +* + CALL DGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND, + $ WORK, IWORK, INFO ) +* +* Compute the solution matrix X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX, + $ INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, 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 110 J = 1, NRHS + DO 100 I = 1, N + X( I, J ) = C( I )*X( I, J ) + 100 CONTINUE + 110 CONTINUE + DO 120 J = 1, NRHS + FERR( J ) = FERR( J ) / COLCND + 120 CONTINUE + END IF + ELSE IF( ROWEQU ) THEN + DO 140 J = 1, NRHS + DO 130 I = 1, N + X( I, J ) = R( I )*X( I, J ) + 130 CONTINUE + 140 CONTINUE + DO 150 J = 1, NRHS + FERR( J ) = FERR( J ) / ROWCND + 150 CONTINUE + END IF +* +* Set INFO = N+1 if the matrix is singular to working precision. +* + IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) + $ INFO = N + 1 +* + WORK( 1 ) = RPVGRW + RETURN +* +* End of DGBSVX +* + END diff --git a/math/lapack/src/main/fortran/dgbsvxx.f b/math/lapack/src/main/fortran/dgbsvxx.f new file mode 100644 index 0000000000..819d20c6d8 --- /dev/null +++ b/math/lapack/src/main/fortran/dgbsvxx.f @@ -0,0 +1,799 @@ +*> \brief DGBSVXX computes the solution to system of linear equations A * X = B for GB matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGBSVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, +* LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, +* RCOND, RPVGRW, BERR, N_ERR_BNDS, +* ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER EQUED, FACT, TRANS +* INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, NRHS, NPARAMS, +* $ N_ERR_BNDS, KL, KU +* DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), +* $ X( LDX , * ),WORK( * ) +* DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), +* $ ERR_BNDS_NORM( NRHS, * ), +* $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGBSVXX uses the LU factorization to compute the solution to a +*> double precision system of linear equations A * X = B, where A is an +*> N-by-N matrix and X and B are N-by-NRHS matrices. +*> +*> If requested, both normwise and maximum componentwise error bounds +*> are returned. DGBSVXX will return a solution with a tiny +*> guaranteed error (O(eps) where eps is the working machine +*> precision) unless the matrix is very ill-conditioned, in which +*> case a warning is returned. Relevant condition numbers also are +*> calculated and returned. +*> +*> DGBSVXX accepts user-provided factorizations and equilibration +*> factors; see the definitions of the FACT and EQUED options. +*> Solving with refinement and using a factorization from a previous +*> DGBSVXX call will also produce a solution with either O(eps) +*> errors or warnings, but we cannot make that claim for general +*> user-provided factorizations and equilibration factors if they +*> differ from what DGBSVXX would itself produce. +*> \endverbatim +* +*> \par Description: +* ================= +*> +*> \verbatim +*> +*> The following steps are performed: +*> +*> 1. If FACT = 'E', double precision scaling factors are computed to equilibrate +*> the system: +*> +*> TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +*> TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +*> TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +*> +*> Whether or not the system will be equilibrated depends on the +*> scaling of the matrix A, but if equilibration is used, A is +*> overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') +*> or diag(C)*B (if TRANS = 'T' or 'C'). +*> +*> 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +*> the matrix A (after equilibration if FACT = 'E') as +*> +*> A = P * L * U, +*> +*> where P is a permutation matrix, L is a unit lower triangular +*> matrix, and U is upper triangular. +*> +*> 3. If some U(i,i)=0, so that U is exactly singular, then the +*> routine returns with INFO = i. Otherwise, the factored form of A +*> is used to estimate the condition number of the matrix A (see +*> argument RCOND). If the reciprocal of the condition number is less +*> than machine precision, the routine still goes on to solve for X +*> and compute error bounds as described below. +*> +*> 4. The system of equations is solved for X using the factored form +*> of A. +*> +*> 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +*> the routine will use iterative refinement to try to get a small +*> error and error bounds. Refinement calculates the residual to at +*> least twice the working precision. +*> +*> 6. If equilibration was used, the matrix X is premultiplied by +*> diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so +*> that it solves the original system before equilibration. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> Some optional parameters are bundled in the PARAMS array. These +*> settings determine how refinement is performed, but often the +*> defaults are acceptable. If the defaults are acceptable, users +*> can pass NPARAMS = 0 which prevents the source code from accessing +*> the PARAMS argument. +*> \endverbatim +*> +*> \param[in] FACT +*> \verbatim +*> FACT is 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. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals within the band of A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals within the band of A. KU >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the matrix A in band storage, in rows 1 to KL+KU+1. +*> The j-th column of A is stored in the j-th column of the +*> array AB as follows: +*> AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) +*> +*> If FACT = 'F' and EQUED is not 'N', then AB must have been +*> equilibrated by the scaling factors in R and/or C. AB is not +*> modified if FACT = 'F' or 'N', or if FACT = 'E' and +*> EQUED = 'N' on exit. +*> +*> On exit, if EQUED .ne. 'N', A is scaled as follows: +*> EQUED = 'R': A := diag(R) * A +*> EQUED = 'C': A := A * diag(C) +*> EQUED = 'B': A := diag(R) * A * diag(C). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KL+KU+1. +*> \endverbatim +*> +*> \param[in,out] AFB +*> \verbatim +*> AFB is DOUBLE PRECISION array, dimension (LDAFB,N) +*> If FACT = 'F', then AFB is an input argument and on entry +*> contains details of the LU factorization of the band matrix +*> A, as computed by DGBTRF. U is stored as an upper triangular +*> band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, +*> and the multipliers used during the factorization are stored +*> in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is +*> the factored form of the equilibrated matrix A. +*> +*> If FACT = 'N', then AF is an output argument and on exit +*> returns the factors L and U from the factorization A = P*L*U +*> of the original matrix A. +*> +*> If FACT = 'E', then AF is an output argument and on exit +*> returns the factors L and U from the factorization A = P*L*U +*> of the equilibrated matrix A (see the description of A for +*> the form of the equilibrated matrix). +*> \endverbatim +*> +*> \param[in] LDAFB +*> \verbatim +*> LDAFB is INTEGER +*> The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. +*> \endverbatim +*> +*> \param[in,out] IPIV +*> \verbatim +*> IPIV is 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. +*> \endverbatim +*> +*> \param[in,out] EQUED +*> \verbatim +*> EQUED is 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. +*> \endverbatim +*> +*> \param[in,out] R +*> \verbatim +*> R is DOUBLE PRECISION array, dimension (N) +*> The row scale factors for A. If EQUED = 'R' or 'B', A is +*> multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +*> is not accessed. R is an input argument if FACT = 'F'; +*> otherwise, R is an output argument. If FACT = 'F' and +*> EQUED = 'R' or 'B', each element of R must be positive. +*> If R is output, each element of R is a power of the radix. +*> If R is input, each element of R should be a power of the radix +*> to ensure a reliable solution and error estimates. Scaling by +*> powers of the radix does not cause rounding errors unless the +*> result underflows or overflows. Rounding errors during scaling +*> lead to refining with a matrix that is not equivalent to the +*> input matrix, producing error estimates that may not be +*> reliable. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> The column scale factors for A. If EQUED = 'C' or 'B', A is +*> multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +*> is not accessed. C is an input argument if FACT = 'F'; +*> otherwise, C is an output argument. If FACT = 'F' and +*> EQUED = 'C' or 'B', each element of C must be positive. +*> If C is output, each element of C is a power of the radix. +*> If C is input, each element of C should be a power of the radix +*> to ensure a reliable solution and error estimates. Scaling by +*> powers of the radix does not cause rounding errors unless the +*> result underflows or overflows. Rounding errors during scaling +*> lead to refining with a matrix that is not equivalent to the +*> input matrix, producing error estimates that may not be +*> reliable. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, +*> if 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> If INFO = 0, the N-by-NRHS solution matrix X to the original +*> system of equations. Note that A and B are modified on exit +*> if EQUED .ne. 'N', and the solution to the equilibrated system is +*> inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or +*> inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> Reciprocal scaled condition number. This is an estimate of the +*> reciprocal Skeel condition number of the matrix A after +*> equilibration (if done). If this is less than the machine +*> precision (in particular, if it is zero), the matrix is singular +*> to working precision. Note that the error may still be small even +*> if this number is very small and the matrix appears ill- +*> conditioned. +*> \endverbatim +*> +*> \param[out] RPVGRW +*> \verbatim +*> RPVGRW is DOUBLE PRECISION +*> Reciprocal pivot growth. On exit, this contains the reciprocal +*> pivot growth factor norm(A)/norm(U). The "max absolute element" +*> norm is used. If this is much less than 1, then the stability of +*> the LU factorization of the (equilibrated) matrix A could be poor. +*> This also means that the solution X, estimated condition numbers, +*> and error bounds could be unreliable. If factorization fails with +*> 0 for the leading INFO columns of A. In DGESVX, this quantity is +*> returned in WORK(1). +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is DOUBLE PRECISION array, dimension (NRHS) +*> Componentwise relative backward error. This is the +*> componentwise relative backward error of each solution vector X(j) +*> (i.e., the smallest relative change in any element of A or B that +*> makes X(j) an exact solution). +*> \endverbatim +*> +*> \param[in] N_ERR_BNDS +*> \verbatim +*> N_ERR_BNDS is INTEGER +*> Number of error bounds to return for each right hand side +*> and each type (normwise or componentwise). See ERR_BNDS_NORM and +*> ERR_BNDS_COMP below. +*> \endverbatim +*> +*> \param[out] ERR_BNDS_NORM +*> \verbatim +*> ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> normwise relative error, which is defined as follows: +*> +*> Normwise relative error in the ith solution vector: +*> max_j (abs(XTRUE(j,i) - X(j,i))) +*> ------------------------------ +*> max_j abs(X(j,i)) +*> +*> The array is indexed by the type of error information as described +*> below. There currently are up to three pieces of information +*> returned. +*> +*> The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_NORM(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * dlamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * dlamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated normwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * dlamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*A, where S scales each row by a power of the +*> radix so all absolute row sums of Z are approximately 1. +*> +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[out] ERR_BNDS_COMP +*> \verbatim +*> ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> componentwise relative error, which is defined as follows: +*> +*> Componentwise relative error in the ith solution vector: +*> abs(XTRUE(j,i) - X(j,i)) +*> max_j ---------------------- +*> abs(X(j,i)) +*> +*> The array is indexed by the right-hand side i (on which the +*> componentwise relative error depends), and the type of error +*> information as described below. There currently are up to three +*> pieces of information returned for each right-hand side. If +*> componentwise accuracy is not requested (PARAMS(3) = 0.0), then +*> ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +*> the first (:,N_ERR_BNDS) entries are returned. +*> +*> The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_COMP(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * dlamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * dlamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated componentwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * dlamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*(A*diag(x)), where x is the solution for the +*> current right-hand side and S scales each row of +*> A*diag(x) by a power of the radix so all absolute row +*> sums of Z are approximately 1. +*> +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[in] NPARAMS +*> \verbatim +*> NPARAMS is INTEGER +*> Specifies the number of parameters set in PARAMS. If .LE. 0, the +*> PARAMS array is never referenced and default values are used. +*> \endverbatim +*> +*> \param[in,out] PARAMS +*> \verbatim +*> PARAMS is DOUBLE PRECISION array, dimension (NPARAMS) +*> Specifies algorithm parameters. If an entry is .LT. 0.0, then +*> that entry will be filled with default value used for that +*> parameter. Only positions up to NPARAMS are accessed; defaults +*> are used for higher-numbered parameters. +*> +*> PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +*> refinement or not. +*> Default: 1.0D+0 +*> = 0.0 : No refinement is performed, and no error bounds are +*> computed. +*> = 1.0 : Use the extra-precise refinement algorithm. +*> (other values are reserved for future use) +*> +*> PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +*> computations allowed for refinement. +*> Default: 10 +*> Aggressive: Set to 100 to permit convergence using approximate +*> factorizations or factorizations other than LU. If +*> the factorization uses a technique other than +*> Gaussian elimination, the guarantees in +*> err_bnds_norm and err_bnds_comp may no longer be +*> trustworthy. +*> +*> PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +*> will attempt to find a solution with small componentwise +*> relative error in the double-precision algorithm. Positive +*> is true, 0.0 is false. +*> Default: 1.0 (attempt componentwise convergence) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Successful exit. The solution to every right-hand side is +*> guaranteed. +*> < 0: If INFO = -i, the i-th argument had an illegal value +*> > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +*> has been completed, but the factor U is exactly singular, so +*> the solution and error bounds could not be computed. RCOND = 0 +*> is returned. +*> = N+J: The solution corresponding to the Jth right-hand side is +*> not guaranteed. The solutions corresponding to other right- +*> hand sides K with K > J may not be guaranteed as well, but +*> only the first such right-hand side is reported. If a small +*> componentwise error is not requested (PARAMS(3) = 0.0) then +*> the Jth right-hand side is the first with a normwise error +*> bound that is not guaranteed (the smallest J such +*> that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +*> the Jth right-hand side is the first with either a normwise or +*> componentwise error bound that is not guaranteed (the smallest +*> J such that either ERR_BNDS_NORM(J,1) = 0.0 or +*> ERR_BNDS_COMP(J,1) = 0.0). See the definition of +*> ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +*> about all of the right-hand sides check ERR_BNDS_NORM or +*> ERR_BNDS_COMP. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleGBsolve +* +* ===================================================================== + SUBROUTINE DGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, + $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, + $ RCOND, RPVGRW, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, TRANS + INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS, KL, KU + DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ X( LDX , * ),WORK( * ) + DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU + INTEGER INFEQU, I, J + DOUBLE PRECISION AMAX, BIGNUM, COLCND, RCMAX, RCMIN, + $ ROWCND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, DLAMCH, DLA_GBRPVGRW + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLA_GBRPVGRW +* .. +* .. External Subroutines .. + EXTERNAL DGBEQUB, DGBTRF, DGBTRS, DLACPY, DLAQGB, + $ XERBLA, DLASCL2, DGBRFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + NOTRAN = LSAME( TRANS, 'N' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + ROWEQU = .FALSE. + COLEQU = .FALSE. + ELSE + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in DGBRFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until DGBRFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KL.LT.0 ) THEN + INFO = -4 + ELSE IF( KU.LT.0 ) THEN + INFO = -5 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -8 + ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN + INFO = -10 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -12 + ELSE + IF( ROWEQU ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 10 J = 1, N + RCMIN = MIN( RCMIN, R( J ) ) + RCMAX = MAX( RCMAX, R( J ) ) + 10 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -13 + ELSE IF( N.GT.0 ) THEN + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + ROWCND = ONE + END IF + END IF + IF( COLEQU .AND. INFO.EQ.0 ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 20 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 20 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -14 + ELSE IF( N.GT.0 ) THEN + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + COLCND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGBSVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL DGBEQUB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL DLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, EQUED ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* If the scaling factors are not applied, set them to 1.0. +* + IF ( .NOT.ROWEQU ) THEN + DO J = 1, N + R( J ) = 1.0D+0 + END DO + END IF + IF ( .NOT.COLEQU ) THEN + DO J = 1, N + C( J ) = 1.0D+0 + END DO + END IF + END IF +* +* Scale the right hand side. +* + IF( NOTRAN ) THEN + IF( ROWEQU ) CALL DLASCL2(N, NRHS, R, B, LDB) + ELSE + IF( COLEQU ) CALL DLASCL2(N, NRHS, C, B, LDB) + END IF +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + DO 40, J = 1, N + DO 30, I = KL+1, 2*KL+KU+1 + AFB( I, J ) = AB( I-KL, J ) + 30 CONTINUE + 40 CONTINUE + CALL DGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + RPVGRW = DLA_GBRPVGRW( N, KL, KU, INFO, AB, LDAB, AFB, + $ LDAFB ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + RPVGRW = DLA_GBRPVGRW( N, KL, KU, N, AB, LDAB, AFB, LDAFB ) +* +* Compute the solution matrix X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX, + $ INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL DGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, + $ IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* Scale solutions. +* + IF ( COLEQU .AND. NOTRAN ) THEN + CALL DLASCL2 ( N, NRHS, C, X, LDX ) + ELSE IF ( ROWEQU .AND. .NOT.NOTRAN ) THEN + CALL DLASCL2 ( N, NRHS, R, X, LDX ) + END IF +* + RETURN +* +* End of DGBSVXX +* + END diff --git a/math/lapack/src/main/fortran/dgbtf2.f b/math/lapack/src/main/fortran/dgbtf2.f new file mode 100644 index 0000000000..eae7d27941 --- /dev/null +++ b/math/lapack/src/main/fortran/dgbtf2.f @@ -0,0 +1,277 @@ +*> \brief \b DGBTF2 computes the LU factorization of a general band matrix using the unblocked version of the algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGBTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, KL, KU, LDAB, M, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION AB( LDAB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGBTF2 computes an LU factorization of a real m-by-n band matrix A +*> using partial pivoting with row interchanges. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals within the band of A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals within the band of A. KU >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the matrix A in band storage, in rows KL+1 to +*> 2*KL+KU+1; rows 1 to KL of the array need not be set. +*> The j-th column of A is stored in the j-th column of the +*> array AB as follows: +*> AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) +*> +*> On exit, details of the factorization: U is stored as an +*> upper triangular band matrix with KL+KU superdiagonals in +*> rows 1 to KL+KU+1, and the multipliers used during the +*> factorization are stored in rows KL+KU+2 to 2*KL+KU+1. +*> See below for further details. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is 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). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = +i, 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The band storage scheme is illustrated by the following example, when +*> M = N = 6, KL = 2, KU = 1: +*> +*> On entry: On exit: +*> +*> * * * + + + * * * u14 u25 u36 +*> * * + + + + * * u13 u24 u35 u46 +*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 +*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 +*> a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * +*> a31 a42 a53 a64 * * m31 m42 m53 m64 * * +*> +*> Array elements marked * are not used by the routine; elements marked +*> + need not be set on entry, but are required by the routine to store +*> elements of U, because of fill-in resulting from the row +*> interchanges. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, KL, KU, LDAB, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION AB( LDAB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, JP, JU, KM, KV +* .. +* .. External Functions .. + INTEGER IDAMAX + EXTERNAL IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL DGER, DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* KV is the number of superdiagonals in the factor U, allowing for +* fill-in. +* + KV = KU + KL +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KL.LT.0 ) THEN + INFO = -3 + ELSE IF( KU.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KL+KV+1 ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGBTF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Gaussian elimination with partial pivoting +* +* Set fill-in elements in columns KU+2 to KV to zero. +* + DO 20 J = KU + 2, MIN( KV, N ) + DO 10 I = KV - J + 2, KL + AB( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE +* +* JU is the index of the last column affected by the current stage +* of the factorization. +* + JU = 1 +* + DO 40 J = 1, MIN( M, N ) +* +* Set fill-in elements in column J+KV to zero. +* + IF( J+KV.LE.N ) THEN + DO 30 I = 1, KL + AB( I, J+KV ) = ZERO + 30 CONTINUE + END IF +* +* Find pivot and test for singularity. KM is the number of +* subdiagonal elements in the current column. +* + KM = MIN( KL, M-J ) + JP = IDAMAX( KM+1, AB( KV+1, J ), 1 ) + IPIV( J ) = JP + J - 1 + IF( AB( KV+JP, J ).NE.ZERO ) THEN + JU = MAX( JU, MIN( J+KU+JP-1, N ) ) +* +* Apply interchange to columns J to JU. +* + IF( JP.NE.1 ) + $ CALL DSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1, + $ AB( KV+1, J ), LDAB-1 ) +* + IF( KM.GT.0 ) THEN +* +* Compute multipliers. +* + CALL DSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 ) +* +* Update trailing submatrix within the band. +* + IF( JU.GT.J ) + $ CALL DGER( KM, JU-J, -ONE, AB( KV+2, J ), 1, + $ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ), + $ LDAB-1 ) + END IF + ELSE +* +* If pivot is zero, set INFO to the index of the pivot +* unless a zero pivot has already been found. +* + IF( INFO.EQ.0 ) + $ INFO = J + END IF + 40 CONTINUE + RETURN +* +* End of DGBTF2 +* + END diff --git a/math/lapack/src/main/fortran/dgbtrf.f b/math/lapack/src/main/fortran/dgbtrf.f new file mode 100644 index 0000000000..86fad80e3f --- /dev/null +++ b/math/lapack/src/main/fortran/dgbtrf.f @@ -0,0 +1,516 @@ +*> \brief \b DGBTRF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGBTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, KL, KU, LDAB, M, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION AB( LDAB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGBTRF computes an LU factorization of a real m-by-n band matrix A +*> using partial pivoting with row interchanges. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals within the band of A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals within the band of A. KU >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the matrix A in band storage, in rows KL+1 to +*> 2*KL+KU+1; rows 1 to KL of the array need not be set. +*> The j-th column of A is stored in the j-th column of the +*> array AB as follows: +*> AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) +*> +*> On exit, details of the factorization: U is stored as an +*> upper triangular band matrix with KL+KU superdiagonals in +*> rows 1 to KL+KU+1, and the multipliers used during the +*> factorization are stored in rows KL+KU+2 to 2*KL+KU+1. +*> See below for further details. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is 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). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = +i, 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The band storage scheme is illustrated by the following example, when +*> M = N = 6, KL = 2, KU = 1: +*> +*> On entry: On exit: +*> +*> * * * + + + * * * u14 u25 u36 +*> * * + + + + * * u13 u24 u35 u46 +*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 +*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 +*> a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * +*> a31 a42 a53 a64 * * m31 m42 m53 m64 * * +*> +*> Array elements marked * are not used by the routine; elements marked +*> + need not be set on entry, but are required by the routine to store +*> elements of U because of fill-in resulting from the row interchanges. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, KL, KU, LDAB, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION AB( LDAB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NBMAX, LDWORK + PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 ) +* .. +* .. Local Scalars .. + INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP, + $ JU, K2, KM, KV, NB, NW + DOUBLE PRECISION TEMP +* .. +* .. Local Arrays .. + DOUBLE PRECISION WORK13( LDWORK, NBMAX ), + $ WORK31( LDWORK, NBMAX ) +* .. +* .. External Functions .. + INTEGER IDAMAX, ILAENV + EXTERNAL IDAMAX, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGBTF2, DGEMM, DGER, DLASWP, DSCAL, + $ DSWAP, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* KV is the number of superdiagonals in the factor U, allowing for +* fill-in +* + KV = KU + KL +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KL.LT.0 ) THEN + INFO = -3 + ELSE IF( KU.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KL+KV+1 ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGBTRF', -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, 'DGBTRF', ' ', M, N, KL, KU ) +* +* The block size must not exceed the limit set by the size of the +* local arrays WORK13 and WORK31. +* + NB = MIN( NB, NBMAX ) +* + IF( NB.LE.1 .OR. NB.GT.KL ) THEN +* +* Use unblocked code +* + CALL DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) + ELSE +* +* Use blocked code +* +* Zero the superdiagonal elements of the work array WORK13 +* + DO 20 J = 1, NB + DO 10 I = 1, J - 1 + WORK13( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE +* +* Zero the subdiagonal elements of the work array WORK31 +* + DO 40 J = 1, NB + DO 30 I = J + 1, NB + WORK31( I, J ) = ZERO + 30 CONTINUE + 40 CONTINUE +* +* Gaussian elimination with partial pivoting +* +* Set fill-in elements in columns KU+2 to KV to zero +* + DO 60 J = KU + 2, MIN( KV, N ) + DO 50 I = KV - J + 2, KL + AB( I, J ) = ZERO + 50 CONTINUE + 60 CONTINUE +* +* JU is the index of the last column affected by the current +* stage of the factorization +* + JU = 1 +* + DO 180 J = 1, MIN( M, N ), NB + JB = MIN( NB, MIN( M, N )-J+1 ) +* +* The active part of the matrix is partitioned +* +* A11 A12 A13 +* A21 A22 A23 +* A31 A32 A33 +* +* Here A11, A21 and A31 denote the current block of JB columns +* which is about to be factorized. The number of rows in the +* partitioning are JB, I2, I3 respectively, and the numbers +* of columns are JB, J2, J3. The superdiagonal elements of A13 +* and the subdiagonal elements of A31 lie outside the band. +* + I2 = MIN( KL-JB, M-J-JB+1 ) + I3 = MIN( JB, M-J-KL+1 ) +* +* J2 and J3 are computed after JU has been updated. +* +* Factorize the current block of JB columns +* + DO 80 JJ = J, J + JB - 1 +* +* Set fill-in elements in column JJ+KV to zero +* + IF( JJ+KV.LE.N ) THEN + DO 70 I = 1, KL + AB( I, JJ+KV ) = ZERO + 70 CONTINUE + END IF +* +* Find pivot and test for singularity. KM is the number of +* subdiagonal elements in the current column. +* + KM = MIN( KL, M-JJ ) + JP = IDAMAX( KM+1, AB( KV+1, JJ ), 1 ) + IPIV( JJ ) = JP + JJ - J + IF( AB( KV+JP, JJ ).NE.ZERO ) THEN + JU = MAX( JU, MIN( JJ+KU+JP-1, N ) ) + IF( JP.NE.1 ) THEN +* +* Apply interchange to columns J to J+JB-1 +* + IF( JP+JJ-1.LT.J+KL ) THEN +* + CALL DSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, + $ AB( KV+JP+JJ-J, J ), LDAB-1 ) + ELSE +* +* The interchange affects columns J to JJ-1 of A31 +* which are stored in the work array WORK31 +* + CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, + $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) + CALL DSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1, + $ AB( KV+JP, JJ ), LDAB-1 ) + END IF + END IF +* +* Compute multipliers +* + CALL DSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ), + $ 1 ) +* +* Update trailing submatrix within the band and within +* the current block. JM is the index of the last column +* which needs to be updated. +* + JM = MIN( JU, J+JB-1 ) + IF( JM.GT.JJ ) + $ CALL DGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1, + $ AB( KV, JJ+1 ), LDAB-1, + $ AB( KV+1, JJ+1 ), LDAB-1 ) + ELSE +* +* If pivot is zero, set INFO to the index of the pivot +* unless a zero pivot has already been found. +* + IF( INFO.EQ.0 ) + $ INFO = JJ + END IF +* +* Copy current column of A31 into the work array WORK31 +* + NW = MIN( JJ-J+1, I3 ) + IF( NW.GT.0 ) + $ CALL DCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1, + $ WORK31( 1, JJ-J+1 ), 1 ) + 80 CONTINUE + IF( J+JB.LE.N ) THEN +* +* Apply the row interchanges to the other blocks. +* + J2 = MIN( JU-J+1, KV ) - JB + J3 = MAX( 0, JU-J-KV+1 ) +* +* Use DLASWP to apply the row interchanges to A12, A22, and +* A32. +* + CALL DLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB, + $ IPIV( J ), 1 ) +* +* Adjust the pivot indices. +* + DO 90 I = J, J + JB - 1 + IPIV( I ) = IPIV( I ) + J - 1 + 90 CONTINUE +* +* Apply the row interchanges to A13, A23, and A33 +* columnwise. +* + K2 = J - 1 + JB + J2 + DO 110 I = 1, J3 + JJ = K2 + I + DO 100 II = J + I - 1, J + JB - 1 + IP = IPIV( II ) + IF( IP.NE.II ) THEN + TEMP = AB( KV+1+II-JJ, JJ ) + AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ ) + AB( KV+1+IP-JJ, JJ ) = TEMP + END IF + 100 CONTINUE + 110 CONTINUE +* +* Update the relevant part of the trailing submatrix +* + IF( J2.GT.0 ) THEN +* +* Update A12 +* + CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', + $ JB, J2, ONE, AB( KV+1, J ), LDAB-1, + $ AB( KV+1-JB, J+JB ), LDAB-1 ) +* + IF( I2.GT.0 ) THEN +* +* Update A22 +* + CALL DGEMM( 'No transpose', 'No transpose', I2, J2, + $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, + $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, + $ AB( KV+1, J+JB ), LDAB-1 ) + END IF +* + IF( I3.GT.0 ) THEN +* +* Update A32 +* + CALL DGEMM( 'No transpose', 'No transpose', I3, J2, + $ JB, -ONE, WORK31, LDWORK, + $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, + $ AB( KV+KL+1-JB, J+JB ), LDAB-1 ) + END IF + END IF +* + IF( J3.GT.0 ) THEN +* +* Copy the lower triangle of A13 into the work array +* WORK13 +* + DO 130 JJ = 1, J3 + DO 120 II = JJ, JB + WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 ) + 120 CONTINUE + 130 CONTINUE +* +* Update A13 in the work array +* + CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', + $ JB, J3, ONE, AB( KV+1, J ), LDAB-1, + $ WORK13, LDWORK ) +* + IF( I2.GT.0 ) THEN +* +* Update A23 +* + CALL DGEMM( 'No transpose', 'No transpose', I2, J3, + $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, + $ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ), + $ LDAB-1 ) + END IF +* + IF( I3.GT.0 ) THEN +* +* Update A33 +* + CALL DGEMM( 'No transpose', 'No transpose', I3, J3, + $ JB, -ONE, WORK31, LDWORK, WORK13, + $ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 ) + END IF +* +* Copy the lower triangle of A13 back into place +* + DO 150 JJ = 1, J3 + DO 140 II = JJ, JB + AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ ) + 140 CONTINUE + 150 CONTINUE + END IF + ELSE +* +* Adjust the pivot indices. +* + DO 160 I = J, J + JB - 1 + IPIV( I ) = IPIV( I ) + J - 1 + 160 CONTINUE + END IF +* +* Partially undo the interchanges in the current block to +* restore the upper triangular form of A31 and copy the upper +* triangle of A31 back into place +* + DO 170 JJ = J + JB - 1, J, -1 + JP = IPIV( JJ ) - JJ + 1 + IF( JP.NE.1 ) THEN +* +* Apply interchange to columns J to JJ-1 +* + IF( JP+JJ-1.LT.J+KL ) THEN +* +* The interchange does not affect A31 +* + CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, + $ AB( KV+JP+JJ-J, J ), LDAB-1 ) + ELSE +* +* The interchange does affect A31 +* + CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, + $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) + END IF + END IF +* +* Copy the current column of A31 back into place +* + NW = MIN( I3, JJ-J+1 ) + IF( NW.GT.0 ) + $ CALL DCOPY( NW, WORK31( 1, JJ-J+1 ), 1, + $ AB( KV+KL+1-JJ+J, JJ ), 1 ) + 170 CONTINUE + 180 CONTINUE + END IF +* + RETURN +* +* End of DGBTRF +* + END diff --git a/math/lapack/src/main/fortran/dgbtrs.f b/math/lapack/src/main/fortran/dgbtrs.f new file mode 100644 index 0000000000..0837349613 --- /dev/null +++ b/math/lapack/src/main/fortran/dgbtrs.f @@ -0,0 +1,269 @@ +*> \brief \b DGBTRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGBTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGBTRS solves a system of linear equations +*> A * X = B or A**T * X = B +*> with a general band matrix A using the LU factorization computed +*> by DGBTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the form of the system of equations. +*> = 'N': A * X = B (No transpose) +*> = 'T': A**T* X = B (Transpose) +*> = 'C': A**T* X = B (Conjugate transpose = Transpose) +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals within the band of A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals within the band of A. KU >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> Details of the LU factorization of the band matrix A, as +*> computed by DGBTRF. U is stored as an upper triangular band +*> matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and +*> the multipliers used during the factorization are stored in +*> rows KL+KU+2 to 2*KL+KU+1. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices; for 1 <= i <= N, row i of the matrix was +*> interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBcomputational +* +* ===================================================================== + SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LNOTI, NOTRAN + INTEGER I, J, KD, L, LM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER, DSWAP, DTBSV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. 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( KL.LT.0 ) THEN + INFO = -3 + ELSE IF( KU.LT.0 ) THEN + INFO = -4 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGBTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + KD = KU + KL + 1 + LNOTI = KL.GT.0 +* + IF( NOTRAN ) THEN +* +* Solve A*X = B. +* +* Solve L*X = B, overwriting B with X. +* +* L is represented as a product of permutations and unit lower +* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), +* where each transformation L(i) is a rank-one modification of +* the identity matrix. +* + IF( LNOTI ) THEN + DO 10 J = 1, N - 1 + LM = MIN( KL, N-J ) + L = IPIV( J ) + IF( L.NE.J ) + $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) + CALL DGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), + $ LDB, B( J+1, 1 ), LDB ) + 10 CONTINUE + END IF +* + DO 20 I = 1, NRHS +* +* Solve U*X = B, overwriting B with X. +* + CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, + $ AB, LDAB, B( 1, I ), 1 ) + 20 CONTINUE +* + ELSE +* +* Solve A**T*X = B. +* + DO 30 I = 1, NRHS +* +* Solve U**T*X = B, overwriting B with X. +* + CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, + $ LDAB, B( 1, I ), 1 ) + 30 CONTINUE +* +* Solve L**T*X = B, overwriting B with X. +* + IF( LNOTI ) THEN + DO 40 J = N - 1, 1, -1 + LM = MIN( KL, N-J ) + CALL DGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), + $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB ) + L = IPIV( J ) + IF( L.NE.J ) + $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) + 40 CONTINUE + END IF + END IF + RETURN +* +* End of DGBTRS +* + END diff --git a/math/lapack/src/main/fortran/dgebak.f b/math/lapack/src/main/fortran/dgebak.f new file mode 100644 index 0000000000..45a86ee573 --- /dev/null +++ b/math/lapack/src/main/fortran/dgebak.f @@ -0,0 +1,268 @@ +*> \brief \b DGEBAK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEBAK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOB, SIDE +* INTEGER IHI, ILO, INFO, LDV, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION SCALE( * ), V( LDV, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is 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. +*> \endverbatim +*> +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'R': V contains right eigenvectors; +*> = 'L': V contains left eigenvectors. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows of the matrix V. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> The integers ILO and IHI determined by DGEBAL. +*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +*> \endverbatim +*> +*> \param[in] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION array, dimension (N) +*> Details of the permutation and scaling factors, as returned +*> by DGEBAL. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of columns of the matrix V. M >= 0. +*> \endverbatim +*> +*> \param[in,out] V +*> \verbatim +*> V is 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. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. LDV >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOB, SIDE + INTEGER IHI, ILO, INFO, LDV, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION SCALE( * ), V( LDV, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dgebal.f b/math/lapack/src/main/fortran/dgebal.f new file mode 100644 index 0000000000..93efd28923 --- /dev/null +++ b/math/lapack/src/main/fortran/dgebal.f @@ -0,0 +1,398 @@ +*> \brief \b DGEBAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEBAL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOB +* INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), SCALE( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> \param[out] IHI +*> \verbatim +*> IHI is 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. +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is DOUBLE 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOB + INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), SCALE( * ) +* .. +* +* ===================================================================== +* +* .. 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 DISNAN, LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL DISNAN, LSAME, IDAMAX, DLAMCH, DNRM2 +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* 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 = DNRM2( L-K+1, A( K, I ), 1 ) + R = DNRM2( L-K+1, A( I, K ), LDA ) + 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 + IF( DISNAN( C+F+CA+R+G+RA ) ) THEN +* +* Exit if NaN to avoid infinite loop +* + INFO = -3 + CALL XERBLA( 'DGEBAL', -INFO ) + RETURN + END IF + 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/math/lapack/src/main/fortran/dgebd2.f b/math/lapack/src/main/fortran/dgebd2.f new file mode 100644 index 0000000000..bb4035dbb1 --- /dev/null +++ b/math/lapack/src/main/fortran/dgebd2.f @@ -0,0 +1,320 @@ +*> \brief \b DGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEBD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), +* $ TAUQ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEBD2 reduces a real general m by n matrix A to upper or lower +*> bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. +*> +*> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows in the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns in the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the m by n general matrix to be reduced. +*> On exit, +*> if m >= n, the diagonal and the first superdiagonal are +*> overwritten with the upper bidiagonal matrix B; the +*> elements below the diagonal, with the array TAUQ, represent +*> the orthogonal matrix Q as a product of elementary +*> reflectors, and the elements above the first superdiagonal, +*> with the array TAUP, represent the orthogonal matrix P as +*> a product of elementary reflectors; +*> if m < n, the diagonal and the first subdiagonal are +*> overwritten with the lower bidiagonal matrix B; the +*> elements below the first subdiagonal, with the array TAUQ, +*> represent the orthogonal matrix Q as a product of +*> elementary reflectors, and the elements above the diagonal, +*> with the array TAUP, represent the orthogonal matrix P as +*> a product of elementary reflectors. +*> See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (min(M,N)) +*> The diagonal elements of the bidiagonal matrix B: +*> D(i) = A(i,i). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (min(M,N)-1) +*> The off-diagonal elements of the bidiagonal matrix B: +*> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; +*> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. +*> \endverbatim +*> +*> \param[out] TAUQ +*> \verbatim +*> TAUQ is DOUBLE PRECISION array dimension (min(M,N)) +*> The scalar factors of the elementary reflectors which +*> represent the orthogonal matrix Q. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP +*> \verbatim +*> TAUP is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors which +*> represent the orthogonal matrix P. See Further Details. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (max(M,N)) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrices Q and P are represented as products of elementary +*> reflectors: +*> +*> If m >= n, +*> +*> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) +*> +*> Each H(i) and G(i) has the form: +*> +*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T +*> +*> where tauq and taup are real scalars, and v and u are real vectors; +*> v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); +*> u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); +*> tauq is stored in TAUQ(i) and taup in TAUP(i). +*> +*> If m < n, +*> +*> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) +*> +*> Each H(i) and G(i) has the form: +*> +*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T +*> +*> where tauq and taup are real scalars, and v and u are real vectors; +*> v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); +*> u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); +*> tauq is stored in TAUQ(i) and taup in TAUP(i). +*> +*> The contents of A on exit are illustrated by the following examples: +*> +*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): +*> +*> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) +*> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) +*> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) +*> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) +*> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) +*> ( v1 v2 v3 v4 v5 ) +*> +*> where d and e denote diagonal and off-diagonal elements of B, vi +*> denotes an element of the vector defining H(i), and ui an element of +*> the vector defining G(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), + $ TAUQ( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dgebrd.f b/math/lapack/src/main/fortran/dgebrd.f new file mode 100644 index 0000000000..885ad9bb41 --- /dev/null +++ b/math/lapack/src/main/fortran/dgebrd.f @@ -0,0 +1,353 @@ +*> \brief \b DGEBRD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEBRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), +* $ TAUQ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows in the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns in the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N general matrix to be reduced. +*> On exit, +*> if m >= n, the diagonal and the first superdiagonal are +*> overwritten with the upper bidiagonal matrix B; the +*> elements below the diagonal, with the array TAUQ, represent +*> the orthogonal matrix Q as a product of elementary +*> reflectors, and the elements above the first superdiagonal, +*> with the array TAUP, represent the orthogonal matrix P as +*> a product of elementary reflectors; +*> if m < n, the diagonal and the first subdiagonal are +*> overwritten with the lower bidiagonal matrix B; the +*> elements below the first subdiagonal, with the array TAUQ, +*> represent the orthogonal matrix Q as a product of +*> elementary reflectors, and the elements above the diagonal, +*> with the array TAUP, represent the orthogonal matrix P as +*> a product of elementary reflectors. +*> See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (min(M,N)) +*> The diagonal elements of the bidiagonal matrix B: +*> D(i) = A(i,i). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (min(M,N)-1) +*> The off-diagonal elements of the bidiagonal matrix B: +*> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; +*> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. +*> \endverbatim +*> +*> \param[out] TAUQ +*> \verbatim +*> TAUQ is DOUBLE PRECISION array dimension (min(M,N)) +*> The scalar factors of the elementary reflectors which +*> represent the orthogonal matrix Q. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP +*> \verbatim +*> TAUP is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors which +*> represent the orthogonal matrix P. See Further Details. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrices Q and P are represented as products of elementary +*> reflectors: +*> +*> If m >= n, +*> +*> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) +*> +*> Each H(i) and G(i) has the form: +*> +*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T +*> +*> where tauq and taup are real scalars, and v and u are real vectors; +*> v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); +*> u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); +*> tauq is stored in TAUQ(i) and taup in TAUP(i). +*> +*> If m < n, +*> +*> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) +*> +*> Each H(i) and G(i) has the form: +*> +*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T +*> +*> where tauq and taup are real scalars, and v and u are real vectors; +*> v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); +*> u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); +*> tauq is stored in TAUQ(i) and taup in TAUP(i). +*> +*> The contents of A on exit are illustrated by the following examples: +*> +*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): +*> +*> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) +*> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) +*> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) +*> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) +*> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) +*> ( v1 v2 v3 v4 v5 ) +*> +*> where d and e denote diagonal and off-diagonal elements of B, vi +*> denotes an element of the vector defining H(i), and ui an element of +*> the vector defining G(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), + $ TAUQ( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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**T - X*U**T +* + 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/math/lapack/src/main/fortran/dgecon.f b/math/lapack/src/main/fortran/dgecon.f new file mode 100644 index 0000000000..be20bbcd2a --- /dev/null +++ b/math/lapack/src/main/fortran/dgecon.f @@ -0,0 +1,261 @@ +*> \brief \b DGECON +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGECON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER NORM +* INTEGER INFO, LDA, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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)) ). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The factors L and U from the factorization A = P*L*U +*> as computed by DGETRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is 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. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(norm(A) * norm(inv(A))). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER INFO, LDA, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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**T). +* + CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A, + $ LDA, WORK, SU, WORK( 3*N+1 ), INFO ) +* +* Multiply by inv(L**T). +* + 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/math/lapack/src/main/fortran/dgeequ.f b/math/lapack/src/main/fortran/dgeequ.f new file mode 100644 index 0000000000..2d9475cc70 --- /dev/null +++ b/math/lapack/src/main/fortran/dgeequ.f @@ -0,0 +1,304 @@ +*> \brief \b DGEEQU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The M-by-N matrix whose equilibration factors are +*> to be computed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] R +*> \verbatim +*> R is DOUBLE PRECISION array, dimension (M) +*> If INFO = 0 or INFO > M, R contains the row scale factors +*> for A. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, C contains the column scale factors for A. +*> \endverbatim +*> +*> \param[out] ROWCND +*> \verbatim +*> ROWCND is 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. +*> \endverbatim +*> +*> \param[out] COLCND +*> \verbatim +*> COLCND is 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. +*> \endverbatim +*> +*> \param[out] AMAX +*> \verbatim +*> AMAX is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, and i is +*> <= M: the i-th row of A is exactly zero +*> > M: the (i-M)-th column of A is exactly zero +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N + DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dgeequb.f b/math/lapack/src/main/fortran/dgeequb.f new file mode 100644 index 0000000000..0404274d37 --- /dev/null +++ b/math/lapack/src/main/fortran/dgeequb.f @@ -0,0 +1,321 @@ +*> \brief \b DGEEQUB +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEEQUB computes row and column scalings intended to equilibrate an +*> M-by-N matrix A and reduce its condition number. R returns the row +*> scale factors and C the column scale factors, chosen to try to make +*> the largest element in each row and column of the matrix B with +*> elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most +*> the radix. +*> +*> R(i) and C(j) are restricted to be a power of the radix between +*> SMLNUM = smallest safe number and BIGNUM = largest safe number. Use +*> of these scaling factors is not guaranteed to reduce the condition +*> number of A but works well in practice. +*> +*> This routine differs from DGEEQU by restricting the scaling factors +*> to a power of the radix. Barring over- and underflow, scaling by +*> these factors introduces no additional rounding errors. However, the +*> scaled entries' magnitudes are no longer approximately 1 but lie +*> between sqrt(radix) and 1/sqrt(radix). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The M-by-N matrix whose equilibration factors are +*> to be computed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] R +*> \verbatim +*> R is DOUBLE PRECISION array, dimension (M) +*> If INFO = 0 or INFO > M, R contains the row scale factors +*> for A. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, C contains the column scale factors for A. +*> \endverbatim +*> +*> \param[out] ROWCND +*> \verbatim +*> ROWCND is 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. +*> \endverbatim +*> +*> \param[out] COLCND +*> \verbatim +*> COLCND is 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. +*> \endverbatim +*> +*> \param[out] AMAX +*> \verbatim +*> AMAX is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, and i is +*> <= M: the i-th row of A is exactly zero +*> > M: the (i-M)-th column of A is exactly zero +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE DGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N + DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM, RADIX, LOGRDX +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, LOG +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEEQUB', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + ROWCND = ONE + COLCND = ONE + AMAX = ZERO + RETURN + END IF +* +* Get machine constants. Assume SMLNUM is a power of the radix. +* + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + RADIX = DLAMCH( 'B' ) + LOGRDX = LOG( RADIX ) +* +* Compute row scale factors. +* + DO 10 I = 1, M + R( I ) = ZERO + 10 CONTINUE +* +* Find the maximum element in each row. +* + DO 30 J = 1, N + DO 20 I = 1, M + R( I ) = MAX( R( I ), ABS( A( I, J ) ) ) + 20 CONTINUE + 30 CONTINUE + DO I = 1, M + IF( R( I ).GT.ZERO ) THEN + R( I ) = RADIX**INT( LOG( R( I ) ) / LOGRDX ) + END IF + END DO +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 40 I = 1, M + RCMAX = MAX( RCMAX, R( I ) ) + RCMIN = MIN( RCMIN, R( I ) ) + 40 CONTINUE + AMAX = RCMAX +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 50 I = 1, M + IF( R( I ).EQ.ZERO ) THEN + INFO = I + RETURN + END IF + 50 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 60 I = 1, M + R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) + 60 CONTINUE +* +* Compute ROWCND = min(R(I)) / max(R(I)). +* + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* +* Compute column scale factors +* + DO 70 J = 1, N + C( J ) = ZERO + 70 CONTINUE +* +* Find the maximum element in each column, +* assuming the row scaling computed above. +* + DO 90 J = 1, N + DO 80 I = 1, M + C( J ) = MAX( C( J ), ABS( A( I, J ) )*R( I ) ) + 80 CONTINUE + IF( C( J ).GT.ZERO ) THEN + C( J ) = RADIX**INT( LOG( C( J ) ) / LOGRDX ) + END IF + 90 CONTINUE +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 100 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 100 CONTINUE +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 110 J = 1, N + IF( C( J ).EQ.ZERO ) THEN + INFO = M + J + RETURN + END IF + 110 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 120 J = 1, N + C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) + 120 CONTINUE +* +* Compute COLCND = min(C(J)) / max(C(J)). +* + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* + RETURN +* +* End of DGEEQUB +* + END diff --git a/math/lapack/src/main/fortran/dgees.f b/math/lapack/src/main/fortran/dgees.f new file mode 100644 index 0000000000..c2723f619f --- /dev/null +++ b/math/lapack/src/main/fortran/dgees.f @@ -0,0 +1,535 @@ +*> \brief DGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEES + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, +* VS, LDVS, WORK, LWORK, BWORK, INFO ) +* +* .. 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 +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVS +*> \verbatim +*> JOBVS is CHARACTER*1 +*> = 'N': Schur vectors are not computed; +*> = 'V': Schur vectors are computed. +*> \endverbatim +*> +*> \param[in] SORT +*> \verbatim +*> SORT is 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). +*> \endverbatim +*> +*> \param[in] SELECT +*> \verbatim +*> SELECT is a 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). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the N-by-N matrix A. +*> On exit, A has been overwritten by its real Schur form T. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] SDIM +*> \verbatim +*> SDIM is 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.) +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] WI +*> \verbatim +*> WI is 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. +*> \endverbatim +*> +*> \param[out] VS +*> \verbatim +*> VS is 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. +*> \endverbatim +*> +*> \param[in] LDVS +*> \verbatim +*> LDVS is INTEGER +*> The leading dimension of the array VS. LDVS >= 1; if +*> JOBVS = 'V', LDVS >= N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) contains the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is 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. +*> \endverbatim +*> +*> \param[out] BWORK +*> \verbatim +*> BWORK is LOGICAL array, dimension (N) +*> Not referenced if SORT = 'N'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEeigen +* +* ===================================================================== + SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, + $ VS, LDVS, WORK, LWORK, BWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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 +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dgeesx.f b/math/lapack/src/main/fortran/dgeesx.f new file mode 100644 index 0000000000..26042a5f91 --- /dev/null +++ b/math/lapack/src/main/fortran/dgeesx.f @@ -0,0 +1,649 @@ +*> \brief DGEESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEESX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, +* WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, +* IWORK, LIWORK, BWORK, INFO ) +* +* .. 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 +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVS +*> \verbatim +*> JOBVS is CHARACTER*1 +*> = 'N': Schur vectors are not computed; +*> = 'V': Schur vectors are computed. +*> \endverbatim +*> +*> \param[in] SORT +*> \verbatim +*> SORT is 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). +*> \endverbatim +*> +*> \param[in] SELECT +*> \verbatim +*> SELECT is a 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). +*> \endverbatim +*> +*> \param[in] SENSE +*> \verbatim +*> SENSE is 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'. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the N-by-N matrix A. +*> On exit, A is overwritten by its real Schur form T. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] SDIM +*> \verbatim +*> SDIM is 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.) +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] WI +*> \verbatim +*> WI is 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. +*> \endverbatim +*> +*> \param[out] VS +*> \verbatim +*> VS is 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. +*> \endverbatim +*> +*> \param[in] LDVS +*> \verbatim +*> LDVS is INTEGER +*> The leading dimension of the array VS. LDVS >= 1, and if +*> JOBVS = 'V', LDVS >= N. +*> \endverbatim +*> +*> \param[out] RCONDE +*> \verbatim +*> RCONDE is 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'. +*> \endverbatim +*> +*> \param[out] RCONDV +*> \verbatim +*> RCONDV is 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'. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is 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. +*> \endverbatim +*> +*> \param[out] BWORK +*> \verbatim +*> BWORK is LOGICAL array, dimension (N) +*> Not referenced if SORT = 'N'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleGEeigen +* +* ===================================================================== + 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.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. 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 +* .. +* +* ===================================================================== +* +* .. 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 + 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 +* (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/math/lapack/src/main/fortran/dgeev.f b/math/lapack/src/main/fortran/dgeev.f new file mode 100644 index 0000000000..2dc1588ab2 --- /dev/null +++ b/math/lapack/src/main/fortran/dgeev.f @@ -0,0 +1,529 @@ +*> \brief DGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, +* LDVR, WORK, LWORK, INFO ) +* +* .. 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( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVL +*> \verbatim +*> JOBVL is CHARACTER*1 +*> = 'N': left eigenvectors of A are not computed; +*> = 'V': left eigenvectors of A are computed. +*> \endverbatim +*> +*> \param[in] JOBVR +*> \verbatim +*> JOBVR is CHARACTER*1 +*> = 'N': right eigenvectors of A are not computed; +*> = 'V': right eigenvectors of A are computed. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the N-by-N matrix A. +*> On exit, A has been overwritten. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] WI +*> \verbatim +*> WI is 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. +*> \endverbatim +*> +*> \param[out] VL +*> \verbatim +*> VL is 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). +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the array VL. LDVL >= 1; if +*> JOBVL = 'V', LDVL >= N. +*> \endverbatim +*> +*> \param[out] VR +*> \verbatim +*> VR is 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). +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. LDVR >= 1; if +*> JOBVR = 'V', LDVR >= N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +* @precisions fortran d -> s +* +*> \ingroup doubleGEeigen +* +* ===================================================================== + SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, + $ LDVR, WORK, LWORK, INFO ) + implicit none +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. 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( * ) +* .. +* +* ===================================================================== +* +* .. 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, + $ LWORK_TREVC, 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, DTREVC3, + $ 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 = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) + CALL DTREVC3( 'L', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, N, NOUT, + $ WORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) + 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 = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) + CALL DTREVC3( 'R', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, N, NOUT, + $ WORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) + 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 = INT( 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 .NE. 0 from DHSEQR, then quit +* + IF( INFO.NE.0 ) + $ GO TO 50 +* + IF( WANTVL .OR. WANTVR ) THEN +* +* Compute left and/or right eigenvectors +* (Workspace: need 4*N, prefer N + N + 2*N*NB) +* + CALL DTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ N, NOUT, WORK( IWRK ), LWORK-IWRK+1, 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/math/lapack/src/main/fortran/dgeevx.f b/math/lapack/src/main/fortran/dgeevx.f new file mode 100644 index 0000000000..edf6a4366e --- /dev/null +++ b/math/lapack/src/main/fortran/dgeevx.f @@ -0,0 +1,694 @@ +*> \brief DGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, +* VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, +* RCONDE, RCONDV, WORK, LWORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER BALANC, JOBVL, JOBVR, SENSE +* INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N +* DOUBLE PRECISION ABNRM +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), RCONDE( * ), RCONDV( * ), +* $ SCALE( * ), VL( LDVL, * ), VR( LDVR, * ), +* $ WI( * ), WORK( * ), WR( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEEVX computes for an N-by-N real nonsymmetric matrix A, the +*> eigenvalues and, optionally, the left and/or right eigenvectors. +*> +*> Optionally also, it computes a balancing transformation to improve +*> the conditioning of the eigenvalues and eigenvectors (ILO, IHI, +*> SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues +*> (RCONDE), and reciprocal condition numbers for the right +*> eigenvectors (RCONDV). +*> +*> The right eigenvector v(j) of A satisfies +*> A * v(j) = lambda(j) * v(j) +*> where lambda(j) is its eigenvalue. +*> The left eigenvector u(j) of A satisfies +*> u(j)**H * A = lambda(j) * u(j)**H +*> where u(j)**H denotes the conjugate-transpose of u(j). +*> +*> The computed eigenvectors are normalized to have Euclidean norm +*> equal to 1 and largest component real. +*> +*> Balancing a matrix means permuting the rows and columns to make it +*> more nearly upper triangular, and applying a diagonal similarity +*> transformation D * A * D**(-1), where D is a diagonal matrix, to +*> make its rows and columns closer in norm and the condition numbers +*> of its eigenvalues and eigenvectors smaller. The computed +*> reciprocal condition numbers correspond to the balanced matrix. +*> Permuting rows and columns will not change the condition numbers +*> (in exact arithmetic) but diagonal scaling will. For further +*> explanation of balancing, see section 4.10.2 of the LAPACK +*> Users' Guide. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] BALANC +*> \verbatim +*> BALANC is CHARACTER*1 +*> Indicates how the input matrix should be diagonally scaled +*> and/or permuted to improve the conditioning of its +*> eigenvalues. +*> = 'N': Do not diagonally scale or permute; +*> = 'P': Perform permutations to make the matrix more nearly +*> upper triangular. Do not diagonally scale; +*> = 'S': Diagonally scale the matrix, i.e. replace A by +*> D*A*D**(-1), where D is a diagonal matrix chosen +*> to make the rows and columns of A more equal in +*> norm. Do not permute; +*> = 'B': Both diagonally scale and permute A. +*> +*> Computed reciprocal condition numbers will be for the matrix +*> after balancing and/or permuting. Permuting does not change +*> condition numbers (in exact arithmetic), but balancing does. +*> \endverbatim +*> +*> \param[in] JOBVL +*> \verbatim +*> JOBVL is CHARACTER*1 +*> = 'N': left eigenvectors of A are not computed; +*> = 'V': left eigenvectors of A are computed. +*> If SENSE = 'E' or 'B', JOBVL must = 'V'. +*> \endverbatim +*> +*> \param[in] JOBVR +*> \verbatim +*> JOBVR is CHARACTER*1 +*> = 'N': right eigenvectors of A are not computed; +*> = 'V': right eigenvectors of A are computed. +*> If SENSE = 'E' or 'B', JOBVR must = 'V'. +*> \endverbatim +*> +*> \param[in] SENSE +*> \verbatim +*> SENSE is CHARACTER*1 +*> Determines which reciprocal condition numbers are computed. +*> = 'N': None are computed; +*> = 'E': Computed for eigenvalues only; +*> = 'V': Computed for right eigenvectors only; +*> = 'B': Computed for eigenvalues and right eigenvectors. +*> +*> If SENSE = 'E' or 'B', both left and right eigenvectors +*> must also be computed (JOBVL = 'V' and JOBVR = 'V'). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the N-by-N matrix A. +*> On exit, A has been overwritten. If JOBVL = 'V' or +*> JOBVR = 'V', A contains the real Schur form of the balanced +*> version of the input matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] WI +*> \verbatim +*> WI is DOUBLE PRECISION array, dimension (N) +*> WR and WI contain the real and imaginary parts, +*> respectively, of the computed eigenvalues. Complex +*> conjugate pairs of eigenvalues will appear consecutively +*> with the eigenvalue having the positive imaginary part +*> first. +*> \endverbatim +*> +*> \param[out] VL +*> \verbatim +*> VL is 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). +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the array VL. LDVL >= 1; if +*> JOBVL = 'V', LDVL >= N. +*> \endverbatim +*> +*> \param[out] VR +*> \verbatim +*> VR is 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). +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. LDVR >= 1, and if +*> JOBVR = 'V', LDVR >= N. +*> \endverbatim +*> +*> \param[out] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[out] IHI +*> \verbatim +*> IHI is INTEGER +*> ILO and IHI are integer values determined when A was +*> balanced. The balanced A(i,j) = 0 if I > J and +*> J = 1,...,ILO-1 or I = IHI+1,...,N. +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION array, dimension (N) +*> Details of the permutations and scaling factors applied +*> when balancing A. If P(j) is the index of the row and column +*> interchanged with row and column j, and D(j) is the scaling +*> factor applied to row and column j, then +*> SCALE(J) = P(J), for J = 1,...,ILO-1 +*> = D(J), for J = ILO,...,IHI +*> = P(J) for J = IHI+1,...,N. +*> The order in which the interchanges are made is N to IHI+1, +*> then 1 to ILO-1. +*> \endverbatim +*> +*> \param[out] ABNRM +*> \verbatim +*> ABNRM is DOUBLE PRECISION +*> The one-norm of the balanced matrix (the maximum +*> of the sum of absolute values of elements of any column). +*> \endverbatim +*> +*> \param[out] RCONDE +*> \verbatim +*> RCONDE is DOUBLE PRECISION array, dimension (N) +*> RCONDE(j) is the reciprocal condition number of the j-th +*> eigenvalue. +*> \endverbatim +*> +*> \param[out] RCONDV +*> \verbatim +*> RCONDV is DOUBLE PRECISION array, dimension (N) +*> RCONDV(j) is the reciprocal condition number of the j-th +*> right eigenvector. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. If SENSE = 'N' or 'E', +*> LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V', +*> LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6). +*> For good performance, LWORK must generally be larger. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*N-2) +*> If SENSE = 'N' or 'E', not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the QR algorithm failed to compute all the +*> eigenvalues, and no eigenvectors or condition numbers +*> have been computed; elements 1:ILO-1 and i+1:N of WR +*> and WI contain eigenvalues which have converged. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +* @precisions fortran d -> s +* +*> \ingroup doubleGEeigen +* +* ===================================================================== + SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, + $ VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, + $ RCONDE, RCONDV, WORK, LWORK, IWORK, INFO ) + implicit none +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER BALANC, JOBVL, JOBVR, SENSE + INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N + DOUBLE PRECISION ABNRM +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), RCONDE( * ), RCONDV( * ), + $ SCALE( * ), VL( LDVL, * ), VR( LDVR, * ), + $ WI( * ), WORK( * ), WR( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE, + $ WNTSNN, WNTSNV + CHARACTER JOB, SIDE + INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, + $ LWORK_TREVC, 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, DTREVC3, + $ DTRSNA, 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' ) + WNTSNN = LSAME( SENSE, 'N' ) + WNTSNE = LSAME( SENSE, 'E' ) + WNTSNV = LSAME( SENSE, 'V' ) + WNTSNB = LSAME( SENSE, 'B' ) + IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'S' ) + $ .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) + $ THEN + INFO = -1 + ELSE IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT.( WNTSNN .OR. WNTSNE .OR. WNTSNB .OR. WNTSNV ) .OR. + $ ( ( WNTSNE .OR. WNTSNB ) .AND. .NOT.( WANTVL .AND. + $ WANTVR ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN + INFO = -11 + ELSE IF( LDVR.LT.1 .OR. ( WANTVR .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. +* 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 = N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) +* + IF( WANTVL ) THEN + CALL DTREVC3( 'L', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, + $ N, NOUT, WORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) + CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL, + $ WORK, -1, INFO ) + ELSE IF( WANTVR ) THEN + CALL DTREVC3( 'R', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, + $ N, NOUT, WORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) + CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR, + $ WORK, -1, INFO ) + ELSE + IF( WNTSNN ) THEN + CALL DHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR, + $ LDVR, WORK, -1, INFO ) + ELSE + CALL DHSEQR( 'S', 'N', N, 1, N, A, LDA, WR, WI, VR, + $ LDVR, WORK, -1, INFO ) + END IF + END IF + HSWORK = INT( WORK(1) ) +* + IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN + MINWRK = 2*N + IF( .NOT.WNTSNN ) + $ MINWRK = MAX( MINWRK, N*N+6*N ) + MAXWRK = MAX( MAXWRK, HSWORK ) + IF( .NOT.WNTSNN ) + $ MAXWRK = MAX( MAXWRK, N*N + 6*N ) + ELSE + MINWRK = 3*N + IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) ) + $ MINWRK = MAX( MINWRK, N*N + 6*N ) + MAXWRK = MAX( MAXWRK, HSWORK ) + MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'DORGHR', + $ ' ', N, 1, N, -1 ) ) + IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) ) + $ MAXWRK = MAX( MAXWRK, N*N + 6*N ) + MAXWRK = MAX( MAXWRK, 3*N ) + END IF + MAXWRK = MAX( MAXWRK, MINWRK ) + END IF + WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -21 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEEVX', -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] +* + ICOND = 0 + 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 and compute ABNRM +* + CALL DGEBAL( BALANC, N, A, LDA, ILO, IHI, SCALE, IERR ) + ABNRM = DLANGE( '1', N, N, A, LDA, DUM ) + IF( SCALEA ) THEN + DUM( 1 ) = ABNRM + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR ) + ABNRM = DUM( 1 ) + END IF +* +* Reduce to upper Hessenberg form +* (Workspace: need 2*N, prefer N+N*NB) +* + ITAU = 1 + 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 2*N-1, prefer 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 1, prefer 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 2*N-1, prefer 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 1, prefer 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 +* If condition numbers desired, compute Schur form +* + IF( WNTSNN ) THEN + JOB = 'E' + ELSE + JOB = 'S' + END IF +* +* (Workspace: need 1, prefer HSWORK (see comments) ) +* + IWRK = ITAU + CALL DHSEQR( JOB, 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, + $ WORK( IWRK ), LWORK-IWRK+1, INFO ) + END IF +* +* If INFO .NE. 0 from DHSEQR, then quit +* + IF( INFO.NE.0 ) + $ GO TO 50 +* + IF( WANTVL .OR. WANTVR ) THEN +* +* Compute left and/or right eigenvectors +* (Workspace: need 3*N, prefer N + 2*N*NB) +* + CALL DTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ N, NOUT, WORK( IWRK ), LWORK-IWRK+1, IERR ) + END IF +* +* Compute condition numbers if desired +* (Workspace: need N*N+6*N unless SENSE = 'E') +* + IF( .NOT.WNTSNN ) THEN + CALL DTRSNA( SENSE, 'A', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ RCONDE, RCONDV, N, NOUT, WORK( IWRK ), N, IWORK, + $ ICOND ) + END IF +* + IF( WANTVL ) THEN +* +* Undo balancing of left eigenvectors +* + CALL DGEBAK( BALANC, 'L', N, ILO, IHI, SCALE, 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( K ) = VL( K, I )**2 + VL( K, I+1 )**2 + 10 CONTINUE + K = IDAMAX( N, WORK, 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 +* + CALL DGEBAK( BALANC, 'R', N, ILO, IHI, SCALE, 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( K ) = VR( K, I )**2 + VR( K, I+1 )**2 + 30 CONTINUE + K = IDAMAX( N, WORK, 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.EQ.0 ) THEN + IF( ( WNTSNV .OR. WNTSNB ) .AND. ICOND.EQ.0 ) + $ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, RCONDV, N, + $ IERR ) + ELSE + 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 DGEEVX +* + END diff --git a/math/lapack/src/main/fortran/dgehd2.f b/math/lapack/src/main/fortran/dgehd2.f new file mode 100644 index 0000000000..4521b66e1a --- /dev/null +++ b/math/lapack/src/main/fortran/dgehd2.f @@ -0,0 +1,225 @@ +*> \brief \b DGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEHD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEHD2 reduces a real general matrix A to upper Hessenberg form H by +*> an orthogonal similarity transformation: Q**T * A * Q = H . +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> It is assumed that A is already upper triangular in rows +*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally +*> set by a previous call to DGEBAL; otherwise they should be +*> set to 1 and N respectively. See Further Details. +*> 1 <= ILO <= IHI <= max(1,N). +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the n by n general matrix to be reduced. +*> On exit, the upper triangle and the first subdiagonal of A +*> are overwritten with the upper Hessenberg matrix H, and the +*> elements below the first subdiagonal, with the array TAU, +*> represent the orthogonal matrix Q as a product of elementary +*> reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-1) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of (ihi-ilo) elementary +*> reflectors +*> +*> Q = H(ilo) H(ilo+1) . . . H(ihi-1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on +*> exit in A(i+2:ihi,i), and tau in TAU(i). +*> +*> The contents of A are illustrated by the following example, with +*> n = 7, ilo = 2 and ihi = 6: +*> +*> on entry, on exit, +*> +*> ( a a a a a a a ) ( a a h h h h a ) +*> ( a a a a a a ) ( a h h h h a ) +*> ( a a a a a a ) ( h h h h h h ) +*> ( a a a a a a ) ( v2 h h h h h ) +*> ( a a a a a a ) ( v2 v3 h h h h ) +*> ( a a a a a a ) ( v2 v3 v4 h h h ) +*> ( a ) ( a ) +*> +*> where a denotes an element of the original matrix A, h denotes a +*> modified element of the upper Hessenberg matrix H, and vi denotes an +*> element of the vector defining H(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + 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/math/lapack/src/main/fortran/dgehrd.f b/math/lapack/src/main/fortran/dgehrd.f new file mode 100644 index 0000000000..23fd872507 --- /dev/null +++ b/math/lapack/src/main/fortran/dgehrd.f @@ -0,0 +1,356 @@ +*> \brief \b DGEHRD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEHRD reduces a real general matrix A to upper Hessenberg form H by +*> an orthogonal similarity transformation: Q**T * A * Q = H . +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> It is assumed that A is already upper triangular in rows +*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally +*> set by a previous call to DGEBAL; otherwise they should be +*> set to 1 and N respectively. See Further Details. +*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the N-by-N general matrix to be reduced. +*> On exit, the upper triangle and the first subdiagonal of A +*> are overwritten with the upper Hessenberg matrix H, and the +*> elements below the first subdiagonal, with the array TAU, +*> represent the orthogonal matrix Q as a product of elementary +*> reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-1) +*> The scalar factors of the elementary reflectors (see Further +*> Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to +*> zero. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= max(1,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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of (ihi-ilo) elementary +*> reflectors +*> +*> Q = H(ilo) H(ilo+1) . . . H(ihi-1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on +*> exit in A(i+2:ihi,i), and tau in TAU(i). +*> +*> The contents of A are illustrated by the following example, with +*> n = 7, ilo = 2 and ihi = 6: +*> +*> on entry, on exit, +*> +*> ( a a a a a a a ) ( a a h h h h a ) +*> ( a a a a a a ) ( a h h h h a ) +*> ( a a a a a a ) ( h h h h h h ) +*> ( a a a a a a ) ( v2 h h h h h ) +*> ( a a a a a a ) ( v2 v3 h h h h ) +*> ( a a a a a a ) ( v2 v3 v4 h h h ) +*> ( a ) ( a ) +*> +*> where a denotes an element of the original matrix A, h denotes a +*> modified element of the upper Hessenberg matrix H, and vi denotes an +*> element of the vector defining H(i). +*> +*> This file is a slight modification of LAPACK-3.0's DGEHRD +*> subroutine incorporating improvements proposed by Quintana-Orti and +*> Van de Geijn (2006). (See DLAHR2.) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT, TSIZE + PARAMETER ( NBMAX = 64, LDT = NBMAX+1, + $ TSIZE = LDT*NBMAX ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, + $ ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWT, J, LDWORK, LWKOPT, NB, + $ NBMIN, NH, NX + DOUBLE PRECISION EI +* .. +* .. 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 + 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.EQ.0 ) THEN +* +* Compute the workspace requirements +* + NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) + LWKOPT = N*NB + TSIZE + WORK( 1 ) = LWKOPT + 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 + 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 +* + IF( LWORK.LT.N*NB+TSIZE ) 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 + TSIZE) ) THEN + NB = (LWORK-TSIZE) / 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 +* + IWT = 1 + N*NB + 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**T +* which performs the reduction, and also the matrix Y = A*V*T +* + CALL DLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), + $ WORK( IWT ), LDT, WORK, LDWORK ) +* +* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the +* right, computing A := A - Y * V**T. 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, + $ WORK( IWT ), 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 ) = LWKOPT +* + RETURN +* +* End of DGEHRD +* + END diff --git a/math/lapack/src/main/fortran/dgelq.f b/math/lapack/src/main/fortran/dgelq.f new file mode 100644 index 0000000000..ece6450791 --- /dev/null +++ b/math/lapack/src/main/fortran/dgelq.f @@ -0,0 +1,306 @@ +* +* Definition: +* =========== +* +* SUBROUTINE DGELQ( M, N, A, LDA, T, TSIZE, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DGELQ computes a LQ factorization of an M-by-N matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the M-by-min(M,N) lower trapezoidal matrix L +*> (L is lower triangular if M <= N); +*> the elements above the diagonal are used to store part of the +*> data structure to represent Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (MAX(5,TSIZE)) +*> On exit, if INFO = 0, T(1) returns optimal (or either minimal +*> or optimal, if query is assumed) TSIZE. See TSIZE for details. +*> Remaining T contains part of the data structure used to represent Q. +*> If one wants to apply or construct Q, then one needs to keep T +*> (in addition to A) and pass it to further subroutines. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> If TSIZE >= 5, the dimension of the array T. +*> If TSIZE = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If TSIZE = -1, the routine calculates optimal size of T for the +*> optimum performance and returns this value in T(1). +*> If TSIZE = -2, the routine calculates minimal size of T and +*> returns this value in T(1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) contains optimal (or either minimal +*> or optimal, if query was assumed) LWORK. +*> See LWORK for details. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If LWORK = -1, the routine calculates optimal size of WORK for the +*> optimal performance and returns this value in WORK(1). +*> If LWORK = -2, the routine calculates minimal size of WORK and +*> returns this value in WORK(1). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> The goal of the interface is to give maximum freedom to the developers for +*> creating any LQ factorization algorithm they wish. The triangular +*> (trapezoidal) L has to be stored in the lower part of A. The lower part of A +*> and the array T can be used to store any relevant information for applying or +*> constructing the Q factor. The WORK array can safely be discarded after exit. +*> +*> Caution: One should not expect the sizes of T and WORK to be the same from one +*> LAPACK implementation to the other, or even from one execution to the other. +*> A workspace query (for T and WORK) is needed at each execution. However, +*> for a given execution, the size of T and WORK are fixed and will not change +*> from one query to the next. +*> +*> \endverbatim +*> +*> \par Further Details particular to this LAPACK implementation: +* ============================================================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> DLASWLQ or DGELQT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, DGELQ will use either +*> DLASWLQ (if the matrix is short-and-wide) or DGELQT to compute +*> the LQ factorization. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGELQ( M, N, A, LDA, T, TSIZE, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. -- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY, LMINWS, MINT, MINW + INTEGER MB, NB, MINTSZ, NBLCKS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGELQT, DLASWLQ, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, MOD +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 +* + LQUERY = ( TSIZE.EQ.-1 .OR. TSIZE.EQ.-2 .OR. + $ LWORK.EQ.-1 .OR. LWORK.EQ.-2 ) +* + MINT = .FALSE. + MINW = .FALSE. + IF( TSIZE.EQ.-2 .OR. LWORK.EQ.-2 ) THEN + IF( TSIZE.NE.-1 ) MINT = .TRUE. + IF( LWORK.NE.-1 ) MINW = .TRUE. + END IF +* +* Determine the block size +* + IF( MIN( M, N ).GT.0 ) THEN + MB = ILAENV( 1, 'DGELQ ', ' ', M, N, 1, -1 ) + NB = ILAENV( 1, 'DGELQ ', ' ', M, N, 2, -1 ) + ELSE + MB = 1 + NB = N + END IF + IF( MB.GT.MIN( M, N ) .OR. MB.LT.1 ) MB = 1 + IF( NB.GT.N .OR. NB.LE.M ) NB = N + MINTSZ = M + 5 + IF ( NB.GT.M .AND. N.GT.M ) THEN + IF( MOD( N - M, NB - M ).EQ.0 ) THEN + NBLCKS = ( N - M ) / ( NB - M ) + ELSE + NBLCKS = ( N - M ) / ( NB - M ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* +* Determine if the workspace size satisfies minimal size +* + LMINWS = .FALSE. + IF( ( TSIZE.LT.MAX( 1, MB*M*NBLCKS + 5 ) .OR. LWORK.LT.MB*M ) + $ .AND. ( LWORK.GE.M ) .AND. ( TSIZE.GE.MINTSZ ) + $ .AND. ( .NOT.LQUERY ) ) THEN + IF( TSIZE.LT.MAX( 1, MB*M*NBLCKS + 5 ) ) THEN + LMINWS = .TRUE. + MB = 1 + NB = N + END IF + IF( LWORK.LT.MB*M ) THEN + LMINWS = .TRUE. + MB = 1 + END IF + END IF +* + 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( TSIZE.LT.MAX( 1, MB*M*NBLCKS + 5 ) + $ .AND. ( .NOT.LQUERY ) .AND. ( .NOT.LMINWS ) ) THEN + INFO = -6 + ELSE IF( ( LWORK.LT.MAX( 1, M*MB ) ) .AND .( .NOT.LQUERY ) + $ .AND. ( .NOT.LMINWS ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( MINT ) THEN + T( 1 ) = MINTSZ + ELSE + T( 1 ) = MB*M*NBLCKS + 5 + END IF + T( 2 ) = MB + T( 3 ) = NB + IF( MINW ) THEN + WORK( 1 ) = MAX( 1, N ) + ELSE + WORK( 1 ) = MAX( 1, MB*M ) + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGELQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N ).EQ.0 ) THEN + RETURN + END IF +* +* The LQ Decomposition +* + IF( ( N.LE.M ) .OR. ( NB.LE.M ) .OR. ( NB.GE.N ) ) THEN + CALL DGELQT( M, N, MB, A, LDA, T( 6 ), MB, WORK, INFO ) + ELSE + CALL DLASWLQ( M, N, MB, NB, A, LDA, T( 6 ), MB, WORK, + $ LWORK, INFO ) + END IF +* + WORK( 1 ) = MAX( 1, MB*M ) +* + RETURN +* +* End of DGELQ +* + END diff --git a/math/lapack/src/main/fortran/dgelq2.f b/math/lapack/src/main/fortran/dgelq2.f new file mode 100644 index 0000000000..04aa57fc19 --- /dev/null +++ b/math/lapack/src/main/fortran/dgelq2.f @@ -0,0 +1,192 @@ +*> \brief \b DGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGELQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGELQ2 computes an LQ factorization of a real m by n matrix A: +*> A = L * Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the m by n matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the m by min(m,n) lower trapezoidal matrix L (L is +*> lower triangular if m <= n); the elements above the diagonal, +*> with the array TAU, represent the orthogonal matrix Q as a +*> product of elementary reflectors (see Further Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(k) . . . H(2) H(1), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), +*> and tau in TAU(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K + 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/math/lapack/src/main/fortran/dgelqf.f b/math/lapack/src/main/fortran/dgelqf.f new file mode 100644 index 0000000000..834c47168f --- /dev/null +++ b/math/lapack/src/main/fortran/dgelqf.f @@ -0,0 +1,269 @@ +*> \brief \b DGELQF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGELQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGELQF computes an LQ factorization of a real M-by-N matrix A: +*> A = L * Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the m-by-min(m,n) lower trapezoidal matrix L (L is +*> lower triangular if m <= n); the elements above the diagonal, +*> with the array TAU, represent the orthogonal matrix Q as a +*> product of elementary reflectors (see Further Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(k) . . . H(2) H(1), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), +*> and tau in TAU(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dgelqt.f b/math/lapack/src/main/fortran/dgelqt.f new file mode 100644 index 0000000000..b11e9d6eee --- /dev/null +++ b/math/lapack/src/main/fortran/dgelqt.f @@ -0,0 +1,210 @@ +*> \brief \b DGELQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDT, M, N, MB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGELQT computes a blocked LQ factorization of a real M-by-N matrix A +*> using the compact WY representation of Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. MIN(M,N) >= MB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the M-by-MIN(M,N) lower trapezoidal matrix L (L is +*> lower triangular if M <= N); the elements above the diagonal +*> are the rows of V. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,MIN(M,N)) +*> The upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See below +*> for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MB*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix V stores the elementary reflectors H(i) in the i-th column +*> below the diagonal. For example, if M=5 and N=3, the matrix V is +*> +*> V = ( 1 v1 v1 v1 v1 ) +*> ( 1 v2 v2 v2 ) +*> ( 1 v3 v3 ) +*> +*> +*> where the vi's represent the vectors which define H(i), which are returned +*> in the matrix A. The 1's along the diagonal of V are not stored in A. +*> Let K=MIN(M,N). The number of blocks is B = ceiling(K/NB), where each +*> block is of order NB except for the last block, which is of order +*> IB = K - (B-1)*NB. For each of the B blocks, a upper triangular block +*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB +*> for the last block) T's are stored in the NB-by-N matrix T as +*> +*> T = (T1 T2 ... TB). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDT, M, N, MB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I, IB, IINFO, K +* .. +* .. External Subroutines .. + EXTERNAL DGEQRT2, DGEQRT3, DLARFB, XERBLA +* .. +* .. 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( MB.LT.1 .OR. ( MB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDT.LT.MB ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGELQT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + K = MIN( M, N ) + IF( K.EQ.0 ) RETURN +* +* Blocked loop of length K +* + DO I = 1, K, MB + IB = MIN( K-I+1, MB ) +* +* Compute the LQ factorization of the current block A(I:M,I:I+IB-1) +* + CALL DGELQT3( IB, N-I+1, A(I,I), LDA, T(1,I), LDT, IINFO ) + IF( I+IB.LE.M ) THEN +* +* Update by applying H**T to A(I:M,I+IB:N) from the right +* + CALL DLARFB( 'R', 'N', 'F', 'R', M-I-IB+1, N-I+1, IB, + $ A( I, I ), LDA, T( 1, I ), LDT, + $ A( I+IB, I ), LDA, WORK , M-I-IB+1 ) + END IF + END DO + RETURN +* +* End of DGELQT +* + END diff --git a/math/lapack/src/main/fortran/dgelqt3.f b/math/lapack/src/main/fortran/dgelqt3.f new file mode 100644 index 0000000000..b0bb242a61 --- /dev/null +++ b/math/lapack/src/main/fortran/dgelqt3.f @@ -0,0 +1,259 @@ +*> \brief \b DGELQT3 recursively computes a LQ factorization of a general real or complex matrix using the compact WY representation of Q. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQRT3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* RECURSIVE SUBROUTINE DGELQT3( M, N, A, LDA, T, LDT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, LDT +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( LDT, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGELQT3 recursively computes a LQ factorization of a real M-by-N +*> matrix A, using the compact WY representation of Q. +*> +*> Based on the algorithm of Elmroth and Gustavson, +*> IBM J. Res. Develop. Vol 44 No. 4 July 2000. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M =< N. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the real M-by-N matrix A. On exit, the elements on and +*> below the diagonal contain the N-by-N lower triangular matrix L; the +*> elements above the diagonal are the rows of V. See below for +*> further details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> The N-by-N upper triangular factor of the block reflector. +*> The elements on and above the diagonal contain the block +*> reflector T; the elements below the diagonal are not used. +*> See below for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix V stores the elementary reflectors H(i) in the i-th column +*> below the diagonal. For example, if M=5 and N=3, the matrix V is +*> +*> V = ( 1 v1 v1 v1 v1 ) +*> ( 1 v2 v2 v2 ) +*> ( 1 v3 v3 v3 ) +*> +*> +*> where the vi's represent the vectors which define H(i), which are returned +*> in the matrix A. The 1's along the diagonal of V are not stored in A. The +*> block reflector H is then given by +*> +*> H = I - V * T * V**T +*> +*> where V**T is the transpose of V. +*> +*> For details of the algorithm, see Elmroth and Gustavson (cited above). +*> \endverbatim +*> +* ===================================================================== + RECURSIVE SUBROUTINE DGELQT3( M, N, A, LDA, T, LDT, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, LDT +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+00 ) +* .. +* .. Local Scalars .. + INTEGER I, I1, J, J1, M1, M2, N1, N2, IINFO +* .. +* .. External Subroutines .. + EXTERNAL DLARFG, DTRMM, DGEMM, XERBLA +* .. +* .. Executable Statements .. +* + 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 + ELSE IF( LDT .LT. MAX( 1, M ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGELQT3', -INFO ) + RETURN + END IF +* + IF( M.EQ.1 ) THEN +* +* Compute Householder transform when N=1 +* + CALL DLARFG( N, A, A( 1, MIN( 2, N ) ), LDA, T ) +* + ELSE +* +* Otherwise, split A into blocks... +* + M1 = M/2 + M2 = M-M1 + I1 = MIN( M1+1, M ) + J1 = MIN( M+1, N ) +* +* Compute A(1:M1,1:N) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H +* + CALL DGELQT3( M1, N, A, LDA, T, LDT, IINFO ) +* +* Compute A(J1:M,1:N) = Q1^H A(J1:M,1:N) [workspace: T(1:N1,J1:N)] +* + DO I=1,M2 + DO J=1,M1 + T( I+M1, J ) = A( I+M1, J ) + END DO + END DO + CALL DTRMM( 'R', 'U', 'T', 'U', M2, M1, ONE, + & A, LDA, T( I1, 1 ), LDT ) +* + CALL DGEMM( 'N', 'T', M2, M1, N-M1, ONE, A( I1, I1 ), LDA, + & A( 1, I1 ), LDA, ONE, T( I1, 1 ), LDT) +* + CALL DTRMM( 'R', 'U', 'N', 'N', M2, M1, ONE, + & T, LDT, T( I1, 1 ), LDT ) +* + CALL DGEMM( 'N', 'N', M2, N-M1, M1, -ONE, T( I1, 1 ), LDT, + & A( 1, I1 ), LDA, ONE, A( I1, I1 ), LDA ) +* + CALL DTRMM( 'R', 'U', 'N', 'U', M2, M1 , ONE, + & A, LDA, T( I1, 1 ), LDT ) +* + DO I=1,M2 + DO J=1,M1 + A( I+M1, J ) = A( I+M1, J ) - T( I+M1, J ) + T( I+M1, J )=0 + END DO + END DO +* +* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H +* + CALL DGELQT3( M2, N-M1, A( I1, I1 ), LDA, + & T( I1, I1 ), LDT, IINFO ) +* +* Compute T3 = T(J1:N1,1:N) = -T1 Y1^H Y2 T2 +* + DO I=1,M2 + DO J=1,M1 + T( J, I+M1 ) = (A( J, I+M1 )) + END DO + END DO +* + CALL DTRMM( 'R', 'U', 'T', 'U', M1, M2, ONE, + & A( I1, I1 ), LDA, T( 1, I1 ), LDT ) +* + CALL DGEMM( 'N', 'T', M1, M2, N-M, ONE, A( 1, J1 ), LDA, + & A( I1, J1 ), LDA, ONE, T( 1, I1 ), LDT ) +* + CALL DTRMM( 'L', 'U', 'N', 'N', M1, M2, -ONE, T, LDT, + & T( 1, I1 ), LDT ) +* + CALL DTRMM( 'R', 'U', 'N', 'N', M1, M2, ONE, + & T( I1, I1 ), LDT, T( 1, I1 ), LDT ) +* +* +* +* Y = (Y1,Y2); L = [ L1 0 ]; T = [T1 T3] +* [ A(1:N1,J1:N) L2 ] [ 0 T2] +* + END IF +* + RETURN +* +* End of DGELQT3 +* + END diff --git a/math/lapack/src/main/fortran/dgels.f b/math/lapack/src/main/fortran/dgels.f new file mode 100644 index 0000000000..33e6d51bff --- /dev/null +++ b/math/lapack/src/main/fortran/dgels.f @@ -0,0 +1,504 @@ +*> \brief DGELS solves overdetermined or underdetermined systems for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGELS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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 underdetermined 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': the linear system involves A; +*> = 'T': the linear system involves A**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrices B and X. NRHS >=0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, +*> 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= MAX(1,M,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEsolve +* +* ===================================================================== + SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, + $ INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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**T * 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 +* +* Underdetermined system of equations A**T * X = B +* +* B(1:N,1:NRHS) := inv(R**T) * 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,:)**T * 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**T * 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**T) * 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/math/lapack/src/main/fortran/dgelsd.f b/math/lapack/src/main/fortran/dgelsd.f new file mode 100644 index 0000000000..d24b2559a4 --- /dev/null +++ b/math/lapack/src/main/fortran/dgelsd.f @@ -0,0 +1,629 @@ +*> \brief DGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGELSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, +* WORK, LWORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGELSD computes the minimum-norm solution to a real linear least +*> squares problem: +*> minimize 2-norm(| b - A*x |) +*> using the singular value decomposition (SVD) of A. A is an M-by-N +*> matrix which may be rank-deficient. +*> +*> Several right hand side vectors b and solution vectors x can be +*> handled in a single call; they are stored as the columns of the +*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution +*> matrix X. +*> +*> The problem is solved in three steps: +*> (1) Reduce the coefficient matrix A to bidiagonal form with +*> Householder transformations, reducing the original problem +*> into a "bidiagonal least squares problem" (BLS) +*> (2) Solve the BLS using a divide and conquer approach. +*> (3) Apply back all the Householder transformations to solve +*> the original least squares problem. +*> +*> The effective rank of A is determined by treating as zero those +*> singular values which are less than RCOND times the largest singular +*> value. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, A has been destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,max(M,N)). +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is 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)). +*> \endverbatim +*> +*> \param[in] RCOND +*> \verbatim +*> RCOND is 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. +*> \endverbatim +*> +*> \param[out] RANK +*> \verbatim +*> RANK is INTEGER +*> The effective rank of A, i.e., the number of singular values +*> which are greater than RCOND*S(1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK must be at least 1. +*> The exact minimum amount of workspace needed depends on M, +*> N and NRHS. As long as LWORK is at least +*> 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2, +*> if M is greater than or equal to N or +*> 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2, +*> if M is less than N, the code will execute correctly. +*> SMLSIZ is returned by ILAENV and is equal to the maximum +*> size of the subproblems at the bottom of the computation +*> tree (usually about 25), and +*> NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) +*> For good performance, LWORK should generally be larger. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> LIWORK >= max(1, 3 * MINMN * NLVL + 11 * MINMN), +*> where MINMN = MIN( M,N ). +*> On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEsolve +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Ren-Cang Li, Computer Science Division, University of +*> California at Berkeley, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +* +* ===================================================================== + SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, + $ WORK, LWORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ, + $ LDWORK, LIWORK, MAXMN, MAXWRK, MINMN, MINWRK, + $ MM, MNTHR, NLVL, NWORK, SMLSIZ, WLALSD + DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM +* .. +* .. External Subroutines .. + EXTERNAL DGEBRD, DGELQF, DGEQRF, DLABAD, DLACPY, DLALSD, + $ DLASCL, DLASET, DORMBR, DORMLQ, DORMQR, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL ILAENV, DLAMCH, DLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, LOG, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments. +* + INFO = 0 + MINMN = MIN( M, N ) + MAXMN = MAX( M, N ) + MNTHR = ILAENV( 6, 'DGELSD', ' ', M, N, NRHS, -1 ) + 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 +* + SMLSIZ = ILAENV( 9, 'DGELSD', ' ', 0, 0, 0, 0 ) +* +* Compute workspace. +* (Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace needed at that point in the code, +* as well as the preferred amount for good performance. +* NB refers to the optimal block size for the immediately +* following subroutine, as returned by ILAENV.) +* + MINWRK = 1 + LIWORK = 1 + MINMN = MAX( 1, MINMN ) + NLVL = MAX( INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ+1 ) ) / + $ LOG( TWO ) ) + 1, 0 ) +* + IF( INFO.EQ.0 ) THEN + MAXWRK = 0 + LIWORK = 3*MINMN*NLVL + 11*MINMN + MM = M + 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. +* + 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, 'DORMBR', 'PLN', N, NRHS, N, -1 ) ) + WLALSD = 9*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS+(SMLSIZ+1)**2 + MAXWRK = MAX( MAXWRK, 3*N+WLALSD ) + MINWRK = MAX( 3*N+MM, 3*N+NRHS, 3*N+WLALSD ) + END IF + IF( N.GT.M ) THEN + WLALSD = 9*M+2*M*SMLSIZ+8*M*NLVL+M*NRHS+(SMLSIZ+1)**2 + 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, 'DORMBR', 'PLN', M, NRHS, M, -1 ) ) + 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 ) ) + MAXWRK = MAX( MAXWRK, M*M+4*M+WLALSD ) +! XXX: Ensure the Path 2a case below is triggered. The workspace +! calculation should use queries for all routines eventually. + MAXWRK = MAX( MAXWRK, + $ 4*M+M*M+MAX( M, 2*M-4, NRHS, N-3*M ) ) + ELSE +* +* Path 2 - remaining underdetermined cases. +* + MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'DGEBRD', ' ', M, N, + $ -1, -1 ) + MAXWRK = MAX( MAXWRK, 3*M+NRHS* + $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, M, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*M+WLALSD ) + END IF + MINWRK = MAX( 3*M+NRHS, 3*M+M, 3*M+WLALSD ) + END IF + MINWRK = MIN( MINWRK, MAXWRK ) + WORK( 1 ) = MAXWRK + IWORK( 1 ) = LIWORK + + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGELSD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + GO TO 10 + 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 entry 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 10 + END IF +* +* Scale B if max entry 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 +* +* If M < N make sure certain entries of B are zero. +* + IF( M.LT.N ) + $ CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) +* +* 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 + NWORK = ITAU + N +* +* Compute A=Q*R. +* (Workspace: need 2*N, prefer N+N*NB) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK-NWORK+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( NWORK ), LWORK-NWORK+1, INFO ) +* +* Zero out below R. +* + IF( N.GT.1 ) THEN + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) + END IF + END IF +* + IE = 1 + ITAUQ = IE + N + ITAUP = ITAUQ + N + NWORK = ITAUP + N +* +* Bidiagonalize R in A. +* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) +* + CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+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( NWORK ), LWORK-NWORK+1, INFO ) +* +* Solve the bidiagonal least squares problem. +* + CALL DLALSD( 'U', SMLSIZ, N, NRHS, S, WORK( IE ), B, LDB, + $ RCOND, RANK, WORK( NWORK ), IWORK, INFO ) + IF( INFO.NE.0 ) THEN + GO TO 10 + END IF +* +* Multiply B by right bidiagonalizing vectors of R. +* + CALL DORMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ), + $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) +* + ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+ + $ MAX( M, 2*M-4, NRHS, N-3*M, WLALSD ) ) 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, 4*M+M*LDA+WLALSD ) )LDWORK = LDA + ITAU = 1 + NWORK = M + 1 +* +* Compute A=L*Q. +* (Workspace: need 2*M, prefer M+M*NB) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) + IL = NWORK +* +* Copy L to WORK(IL), zeroing out above its diagonal. +* + 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 + NWORK = 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( NWORK ), + $ LWORK-NWORK+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( NWORK ), + $ LWORK-NWORK+1, INFO ) +* +* Solve the bidiagonal least squares problem. +* + CALL DLALSD( 'U', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB, + $ RCOND, RANK, WORK( NWORK ), IWORK, INFO ) + IF( INFO.NE.0 ) THEN + GO TO 10 + END IF +* +* Multiply B by right bidiagonalizing vectors of L. +* + CALL DORMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK, + $ WORK( ITAUP ), B, LDB, WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) +* +* Zero out below first M rows of B. +* + CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) + NWORK = 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( NWORK ), LWORK-NWORK+1, INFO ) +* + ELSE +* +* Path 2 - remaining underdetermined cases. +* + IE = 1 + ITAUQ = IE + M + ITAUP = ITAUQ + M + NWORK = ITAUP + M +* +* Bidiagonalize A. +* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) +* + CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+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( NWORK ), LWORK-NWORK+1, INFO ) +* +* Solve the bidiagonal least squares problem. +* + CALL DLALSD( 'L', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB, + $ RCOND, RANK, WORK( NWORK ), IWORK, INFO ) + IF( INFO.NE.0 ) THEN + GO TO 10 + END IF +* +* Multiply B by right bidiagonalizing vectors of A. +* + CALL DORMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ), + $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) +* + 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 +* + 10 CONTINUE + WORK( 1 ) = MAXWRK + IWORK( 1 ) = LIWORK + RETURN +* +* End of DGELSD +* + END diff --git a/math/lapack/src/main/fortran/dgelss.f b/math/lapack/src/main/fortran/dgelss.f new file mode 100644 index 0000000000..674a7ba784 --- /dev/null +++ b/math/lapack/src/main/fortran/dgelss.f @@ -0,0 +1,747 @@ +*> \brief DGELSS solves overdetermined or underdetermined systems for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGELSS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the first min(m,n) rows of A are overwritten with +*> its right singular vectors, stored rowwise. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,max(M,N)). +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is 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)). +*> \endverbatim +*> +*> \param[in] RCOND +*> \verbatim +*> RCOND is 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. +*> \endverbatim +*> +*> \param[out] RANK +*> \verbatim +*> RANK is INTEGER +*> The effective rank of A, i.e., the number of singular values +*> which are greater than RCOND*S(1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 1, 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEsolve +* +* ===================================================================== + SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, + $ WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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 + INTEGER LWORK_DGEQRF, LWORK_DORMQR, LWORK_DGEBRD, + $ LWORK_DORMBR, LWORK_DORGBR, LWORK_DORMLQ, + $ LWORK_DGELQF + DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR +* .. +* .. Local Arrays .. + DOUBLE PRECISION DUM( 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 +* +* Compute space needed for DGEQRF + CALL DGEQRF( M, N, A, LDA, DUM(1), DUM(1), -1, INFO ) + LWORK_DGEQRF=DUM(1) +* Compute space needed for DORMQR + CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, DUM(1), B, + $ LDB, DUM(1), -1, INFO ) + LWORK_DORMQR=DUM(1) + MM = N + MAXWRK = MAX( MAXWRK, N + LWORK_DGEQRF ) + MAXWRK = MAX( MAXWRK, N + LWORK_DORMQR ) + END IF + IF( M.GE.N ) THEN +* +* Path 1 - overdetermined or exactly determined +* +* Compute workspace needed for DBDSQR +* + BDSPAC = MAX( 1, 5*N ) +* Compute space needed for DGEBRD + CALL DGEBRD( MM, N, A, LDA, S, DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, INFO ) + LWORK_DGEBRD=DUM(1) +* Compute space needed for DORMBR + CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, DUM(1), + $ B, LDB, DUM(1), -1, INFO ) + LWORK_DORMBR=DUM(1) +* Compute space needed for DORGBR + CALL DORGBR( 'P', N, N, N, A, LDA, DUM(1), + $ DUM(1), -1, INFO ) + LWORK_DORGBR=DUM(1) +* Compute total workspace needed + MAXWRK = MAX( MAXWRK, 3*N + LWORK_DGEBRD ) + MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORMBR ) + MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR ) + 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 +* +* Compute space needed for DGELQF + CALL DGELQF( M, N, A, LDA, DUM(1), DUM(1), + $ -1, INFO ) + LWORK_DGELQF=DUM(1) +* Compute space needed for DGEBRD + CALL DGEBRD( M, M, A, LDA, S, DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, INFO ) + LWORK_DGEBRD=DUM(1) +* Compute space needed for DORMBR + CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, + $ DUM(1), B, LDB, DUM(1), -1, INFO ) + LWORK_DORMBR=DUM(1) +* Compute space needed for DORGBR + CALL DORGBR( 'P', M, M, M, A, LDA, DUM(1), + $ DUM(1), -1, INFO ) + LWORK_DORGBR=DUM(1) +* Compute space needed for DORMLQ + CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, DUM(1), + $ B, LDB, DUM(1), -1, INFO ) + LWORK_DORMLQ=DUM(1) +* Compute total workspace needed + MAXWRK = M + LWORK_DGELQF + MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DGEBRD ) + MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DORMBR ) + MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DORGBR ) + 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 + LWORK_DORMLQ ) + ELSE +* +* Path 2 - underdetermined +* +* Compute space needed for DGEBRD + CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, INFO ) + LWORK_DGEBRD=DUM(1) +* Compute space needed for DORMBR + CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, A, LDA, + $ DUM(1), B, LDB, DUM(1), -1, INFO ) + LWORK_DORMBR=DUM(1) +* Compute space needed for DORGBR + CALL DORGBR( 'P', M, N, M, A, LDA, DUM(1), + $ DUM(1), -1, INFO ) + LWORK_DORGBR=DUM(1) + MAXWRK = 3*M + LWORK_DGEBRD + MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORMBR ) + MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR ) + 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, MINMN ) + 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, DUM, + $ 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, DUM, + $ 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/math/lapack/src/main/fortran/dgelsy.f b/math/lapack/src/main/fortran/dgelsy.f new file mode 100644 index 0000000000..1ca238d1f5 --- /dev/null +++ b/math/lapack/src/main/fortran/dgelsy.f @@ -0,0 +1,479 @@ +*> \brief DGELSY solves overdetermined or underdetermined systems for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGELSY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, +* WORK, LWORK, INFO ) +* +* .. 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( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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**T [ inv(T11)*Q1**T*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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, A has been overwritten by details of its +*> complete orthogonal factorization. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M,N). +*> \endverbatim +*> +*> \param[in,out] JPVT +*> \verbatim +*> JPVT is INTEGER array, dimension (N) +*> On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted +*> to the front of 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. +*> \endverbatim +*> +*> \param[in] RCOND +*> \verbatim +*> RCOND is 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. +*> \endverbatim +*> +*> \param[out] RANK +*> \verbatim +*> RANK is 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. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: If INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEsolve +* +*> \par Contributors: +* ================== +*> +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA \n +*> E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain \n +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain \n +*> +* ===================================================================== + SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, + $ WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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( * ) +* .. +* +* ===================================================================== +* +* .. 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**T * 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**T * 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/math/lapack/src/main/fortran/dgemlq.f b/math/lapack/src/main/fortran/dgemlq.f new file mode 100644 index 0000000000..bb6b2868f8 --- /dev/null +++ b/math/lapack/src/main/fortran/dgemlq.f @@ -0,0 +1,284 @@ +* +* Definition: +* =========== +* +* SUBROUTINE DGEMLQ( SIDE, TRANS, M, N, K, A, LDA, T, +* $ TSIZE, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, LDT, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( * ), C(LDC, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEMLQ 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 blocked elementary reflectors computed by short wide LQ +*> factorization (DGELQ) +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension +*> (LDA,M) if SIDE = 'L', +*> (LDA,N) if SIDE = 'R' +*> Part of the data structure to represent Q as returned by DGELQ. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,K). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (MAX(5,TSIZE)). +*> Part of the data structure to represent Q as returned by DGELQ. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> The dimension of the array T. TSIZE >= 5. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1, then a workspace query is assumed. The routine +*> only calculates the size of the WORK array, returns this +*> value as WORK(1), and no error message related to WORK +*> is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> DLASWLQ or DGELQT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, DGELQ will use either +*> DLASWLQ (if the matrix is wide-and-short) or DGELQT to compute +*> the LQ factorization. +*> This version of DGEMLQ will use either DLAMSWLQ or DGEMLQT to +*> multiply matrix Q by another matrix. +*> Further Details in DLAMSWLQ or DGEMLQT. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEMLQ( SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, + $ C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( * ), C( LDC, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER MB, NB, LW, NBLCKS, MN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLAMSWLQ, DGEMLQT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN, MOD +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.EQ.-1 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'T' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) +* + MB = INT( T( 2 ) ) + NB = INT( T( 3 ) ) + IF( LEFT ) THEN + LW = N * MB + MN = M + ELSE + LW = M * MB + MN = N + END IF +* + IF( ( NB.GT.K ) .AND. ( MN.GT.K ) ) THEN + IF( MOD( MN - K, NB - K ) .EQ. 0 ) THEN + NBLCKS = ( MN - K ) / ( NB - K ) + ELSE + NBLCKS = ( MN - K ) / ( NB - K ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) 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.MN ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( TSIZE.LT.5 ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( ( LWORK.LT.MAX( 1, LW ) ) .AND. ( .NOT.LQUERY ) ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LW + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEMLQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N, K ).EQ.0 ) THEN + RETURN + END IF +* + IF( ( LEFT .AND. M.LE.K ) .OR. ( RIGHT .AND. N.LE.K ) + $ .OR. ( NB.LE.K ) .OR. ( NB.GE.MAX( M, N, K ) ) ) THEN + CALL DGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA, + $ T( 6 ), MB, C, LDC, WORK, INFO ) + ELSE + CALL DLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T( 6 ), + $ MB, C, LDC, WORK, LWORK, INFO ) + END IF +* + WORK( 1 ) = LW +* + RETURN +* +* End of DGEMLQ +* + END diff --git a/math/lapack/src/main/fortran/dgemlqt.f b/math/lapack/src/main/fortran/dgemlqt.f new file mode 100644 index 0000000000..41a517a2df --- /dev/null +++ b/math/lapack/src/main/fortran/dgemlqt.f @@ -0,0 +1,289 @@ +*> \brief \b DGEMLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, +* C, LDC, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDV, LDC, M, N, MB, LDT +* .. +* .. Array Arguments .. +* DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEMQRT 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) = I - V T V**T +*> +*> generated using the compact WY representation as returned by DGELQT. +*> +*> Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'C': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size used for the storage of T. K >= MB >= 1. +*> This must be the same value of MB used to generate T +*> in DGELQT. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,K) +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGELQT in the first K rows of its array argument A. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,K) +*> The upper triangular factors of the block reflectors +*> as returned by DGELQT, stored as a MB-by-M matrix. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q C, Q**T C, C Q**T or C Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array. The dimension of +*> WORK is N*MB if SIDE = 'L', or M*MB if SIDE = 'R'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE DGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, + $ C, LDC, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDV, LDC, M, N, MB, LDT +* .. +* .. Array Arguments .. + DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN + INTEGER I, IB, LDWORK, KF, Q +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLARFB +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* .. Test the input arguments .. +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + TRAN = LSAME( TRANS, 'T' ) + NOTRAN = LSAME( TRANS, 'N' ) +* + IF( LEFT ) THEN + LDWORK = MAX( 1, N ) + ELSE IF ( RIGHT ) THEN + LDWORK = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0) THEN + INFO = -5 + ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0)) THEN + INFO = -6 + ELSE IF( LDV.LT.MAX( 1, K ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MB ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -12 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEMLQT', -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 ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + CALL DLARFB( 'L', 'T', 'F', 'R', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( I, 1 ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( RIGHT .AND. TRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + CALL DLARFB( 'R', 'N', 'F', 'R', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( 1, I ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( LEFT .AND. TRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + CALL DLARFB( 'L', 'N', 'F', 'R', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( I, 1 ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( RIGHT .AND. NOTRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + CALL DLARFB( 'R', 'T', 'F', 'R', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( 1, I ), LDC, WORK, LDWORK ) + END DO +* + END IF +* + RETURN +* +* End of DGEMLQT +* + END diff --git a/math/lapack/src/main/fortran/dgemqr.f b/math/lapack/src/main/fortran/dgemqr.f new file mode 100644 index 0000000000..8509b13d97 --- /dev/null +++ b/math/lapack/src/main/fortran/dgemqr.f @@ -0,0 +1,285 @@ +* +* Definition: +* =========== +* +* SUBROUTINE DGEMQR( SIDE, TRANS, M, N, K, A, LDA, T, +* $ TSIZE, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, LDT, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( * ), C( LDC, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEMQR 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 blocked elementary reflectors computed by tall skinny +*> QR factorization (DGEQR) +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,K) +*> Part of the data structure to represent Q as returned by DGEQR. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (MAX(5,TSIZE)). +*> Part of the data structure to represent Q as returned by DGEQR. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> The dimension of the array T. TSIZE >= 5. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1, then a workspace query is assumed. The routine +*> only calculates the size of the WORK array, returns this +*> value as WORK(1), and no error message related to WORK +*> is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> DLATSQR or DGEQRT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, DGEQR will use either +*> DLATSQR (if the matrix is tall-and-skinny) or DGEQRT to compute +*> the QR factorization. +*> This version of DGEMQR will use either DLAMTSQR or DGEMQRT to +*> multiply matrix Q by another matrix. +*> Further Details in DLATMSQR or DGEMQRT. +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEMQR( SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, + $ C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( * ), C( LDC, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER MB, NB, LW, NBLCKS, MN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMQRT, DLAMTSQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN, MOD +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.EQ.-1 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'T' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) +* + MB = INT( T( 2 ) ) + NB = INT( T( 3 ) ) + IF( LEFT ) THEN + LW = N * NB + MN = M + ELSE + LW = MB * NB + MN = N + END IF +* + IF( ( MB.GT.K ) .AND. ( MN.GT.K ) ) THEN + IF( MOD( MN - K, MB - K ).EQ.0 ) THEN + NBLCKS = ( MN - K ) / ( MB - K ) + ELSE + NBLCKS = ( MN - K ) / ( MB - K ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) 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.MN ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, MN ) ) THEN + INFO = -7 + ELSE IF( TSIZE.LT.5 ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( ( LWORK.LT.MAX( 1, LW ) ) .AND. ( .NOT.LQUERY ) ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LW + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEMQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N, K ).EQ.0 ) THEN + RETURN + END IF +* + IF( ( LEFT .AND. M.LE.K ) .OR. ( RIGHT .AND. N.LE.K ) + $ .OR. ( MB.LE.K ) .OR. ( MB.GE.MAX( M, N, K ) ) ) THEN + CALL DGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA, T( 6 ), + $ NB, C, LDC, WORK, INFO ) + ELSE + CALL DLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T( 6 ), + $ NB, C, LDC, WORK, LWORK, INFO ) + END IF +* + WORK( 1 ) = LW +* + RETURN +* +* End of DGEMQR +* + END diff --git a/math/lapack/src/main/fortran/dgemqrt.f b/math/lapack/src/main/fortran/dgemqrt.f new file mode 100644 index 0000000000..12cf929817 --- /dev/null +++ b/math/lapack/src/main/fortran/dgemqrt.f @@ -0,0 +1,291 @@ +*> \brief \b DGEMQRT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, +* C, LDC, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDV, LDC, M, N, NB, LDT +* .. +* .. Array Arguments .. +* DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEMQRT 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) = I - V T V**T +*> +*> generated using the compact WY representation as returned by DGEQRT. +*> +*> Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'C': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The block size used for the storage of T. K >= NB >= 1. +*> This must be the same value of NB used to generate T +*> in CGEQRT. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,K) +*> The i-th column must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> CGEQRT in the first K columns of its array argument A. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,K) +*> The upper triangular factors of the block reflectors +*> as returned by CGEQRT, stored as a NB-by-N matrix. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q C, Q**T C, C Q**T or C Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array. The dimension of +*> WORK is N*NB if SIDE = 'L', or M*NB if SIDE = 'R'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE DGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, + $ C, LDC, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDV, LDC, M, N, NB, LDT +* .. +* .. Array Arguments .. + DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN + INTEGER I, IB, LDWORK, KF, Q +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLARFB +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* .. Test the input arguments .. +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + TRAN = LSAME( TRANS, 'T' ) + NOTRAN = LSAME( TRANS, 'N' ) +* + IF( LEFT ) THEN + LDWORK = MAX( 1, N ) + Q = M + ELSE IF ( RIGHT ) THEN + LDWORK = MAX( 1, M ) + Q = N + END IF + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) 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.Q ) THEN + INFO = -5 + ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN + INFO = -6 + ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.NB ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -12 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEMQRT', -INFO ) + RETURN + END IF +* +* .. Quick return if possible .. +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN +* + IF( LEFT .AND. TRAN ) THEN +* + DO I = 1, K, NB + IB = MIN( NB, K-I+1 ) + CALL DLARFB( 'L', 'T', 'F', 'C', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( I, 1 ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( RIGHT .AND. NOTRAN ) THEN +* + DO I = 1, K, NB + IB = MIN( NB, K-I+1 ) + CALL DLARFB( 'R', 'N', 'F', 'C', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( 1, I ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( LEFT .AND. NOTRAN ) THEN +* + KF = ((K-1)/NB)*NB+1 + DO I = KF, 1, -NB + IB = MIN( NB, K-I+1 ) + CALL DLARFB( 'L', 'N', 'F', 'C', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( I, 1 ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( RIGHT .AND. TRAN ) THEN +* + KF = ((K-1)/NB)*NB+1 + DO I = KF, 1, -NB + IB = MIN( NB, K-I+1 ) + CALL DLARFB( 'R', 'T', 'F', 'C', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( 1, I ), LDC, WORK, LDWORK ) + END DO +* + END IF +* + RETURN +* +* End of DGEMQRT +* + END diff --git a/math/lapack/src/main/fortran/dgeql2.f b/math/lapack/src/main/fortran/dgeql2.f new file mode 100644 index 0000000000..539ef29f26 --- /dev/null +++ b/math/lapack/src/main/fortran/dgeql2.f @@ -0,0 +1,193 @@ +*> \brief \b DGEQL2 computes the QL factorization of a general rectangular matrix using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEQL2 computes a QL factorization of a real m by n matrix A: +*> A = Q * L. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(k) . . . H(2) H(1), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in +*> A(1:m-k+i-1,n-k+i), and tau in TAU(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K + 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/math/lapack/src/main/fortran/dgeqlf.f b/math/lapack/src/main/fortran/dgeqlf.f new file mode 100644 index 0000000000..e8c3f8e53e --- /dev/null +++ b/math/lapack/src/main/fortran/dgeqlf.f @@ -0,0 +1,287 @@ +*> \brief \b DGEQLF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQLF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEQLF computes a QL factorization of a real M-by-N matrix A: +*> A = Q * L. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(k) . . . H(2) H(1), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in +*> A(1:m-k+i-1,n-k+i), and tau in TAU(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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**T 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/math/lapack/src/main/fortran/dgeqp3.f b/math/lapack/src/main/fortran/dgeqp3.f new file mode 100644 index 0000000000..2b9faf663d --- /dev/null +++ b/math/lapack/src/main/fortran/dgeqp3.f @@ -0,0 +1,361 @@ +*> \brief \b DGEQP3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQP3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. +* INTEGER JPVT( * ) +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEQP3 computes a QR factorization with column pivoting of a +*> matrix A: A*P = Q*R using Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] JPVT +*> \verbatim +*> JPVT is INTEGER array, dimension (N) +*> On entry, if JPVT(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. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO=0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real/complex vector +*> with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in +*> A(i+1:m,i), and tau in TAU(i). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain +*> X. Sun, Computer Science Dept., Duke University, USA +*> +* ===================================================================== + SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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 +* +* 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/math/lapack/src/main/fortran/dgeqr.f b/math/lapack/src/main/fortran/dgeqr.f new file mode 100644 index 0000000000..d0a1a18f99 --- /dev/null +++ b/math/lapack/src/main/fortran/dgeqr.f @@ -0,0 +1,307 @@ +* +* Definition: +* =========== +* +* SUBROUTINE DGEQR( M, N, A, LDA, T, TSIZE, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DGEQR computes a QR factorization of an M-by-N matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(M,N)-by-N upper trapezoidal matrix R +*> (R is upper triangular if M >= N); +*> the elements below the diagonal are used to store part of the +*> data structure to represent Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (MAX(5,TSIZE)) +*> On exit, if INFO = 0, T(1) returns optimal (or either minimal +*> or optimal, if query is assumed) TSIZE. See TSIZE for details. +*> Remaining T contains part of the data structure used to represent Q. +*> If one wants to apply or construct Q, then one needs to keep T +*> (in addition to A) and pass it to further subroutines. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> If TSIZE >= 5, the dimension of the array T. +*> If TSIZE = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If TSIZE = -1, the routine calculates optimal size of T for the +*> optimum performance and returns this value in T(1). +*> If TSIZE = -2, the routine calculates minimal size of T and +*> returns this value in T(1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) contains optimal (or either minimal +*> or optimal, if query was assumed) LWORK. +*> See LWORK for details. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If LWORK = -1, the routine calculates optimal size of WORK for the +*> optimal performance and returns this value in WORK(1). +*> If LWORK = -2, the routine calculates minimal size of WORK and +*> returns this value in WORK(1). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> The goal of the interface is to give maximum freedom to the developers for +*> creating any QR factorization algorithm they wish. The triangular +*> (trapezoidal) R has to be stored in the upper part of A. The lower part of A +*> and the array T can be used to store any relevant information for applying or +*> constructing the Q factor. The WORK array can safely be discarded after exit. +*> +*> Caution: One should not expect the sizes of T and WORK to be the same from one +*> LAPACK implementation to the other, or even from one execution to the other. +*> A workspace query (for T and WORK) is needed at each execution. However, +*> for a given execution, the size of T and WORK are fixed and will not change +*> from one query to the next. +*> +*> \endverbatim +*> +*> \par Further Details particular to this LAPACK implementation: +* ============================================================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> DLATSQR or DGEQRT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, DGEQR will use either +*> DLATSQR (if the matrix is tall-and-skinny) or DGEQRT to compute +*> the QR factorization. +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEQR( M, N, A, LDA, T, TSIZE, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. -- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY, LMINWS, MINT, MINW + INTEGER MB, NB, MINTSZ, NBLCKS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLATSQR, DGEQRT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, MOD +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 +* + LQUERY = ( TSIZE.EQ.-1 .OR. TSIZE.EQ.-2 .OR. + $ LWORK.EQ.-1 .OR. LWORK.EQ.-2 ) +* + MINT = .FALSE. + MINW = .FALSE. + IF( TSIZE.EQ.-2 .OR. LWORK.EQ.-2 ) THEN + IF( TSIZE.NE.-1 ) MINT = .TRUE. + IF( LWORK.NE.-1 ) MINW = .TRUE. + END IF +* +* Determine the block size +* + IF( MIN( M, N ).GT.0 ) THEN + MB = ILAENV( 1, 'DGEQR ', ' ', M, N, 1, -1 ) + NB = ILAENV( 1, 'DGEQR ', ' ', M, N, 2, -1 ) + ELSE + MB = M + NB = 1 + END IF + IF( MB.GT.M .OR. MB.LE.N ) MB = M + IF( NB.GT.MIN( M, N ) .OR. NB.LT.1 ) NB = 1 + MINTSZ = N + 5 + IF( MB.GT.N .AND. M.GT.N ) THEN + IF( MOD( M - N, MB - N ).EQ.0 ) THEN + NBLCKS = ( M - N ) / ( MB - N ) + ELSE + NBLCKS = ( M - N ) / ( MB - N ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* +* Determine if the workspace size satisfies minimal size +* + LMINWS = .FALSE. + IF( ( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) .OR. LWORK.LT.NB*N ) + $ .AND. ( LWORK.GE.N ) .AND. ( TSIZE.GE.MINTSZ ) + $ .AND. ( .NOT.LQUERY ) ) THEN + IF( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) ) THEN + LMINWS = .TRUE. + NB = 1 + MB = M + END IF + IF( LWORK.LT.NB*N ) THEN + LMINWS = .TRUE. + NB = 1 + END IF + END IF +* + 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( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) + $ .AND. ( .NOT.LQUERY ) .AND. ( .NOT.LMINWS ) ) THEN + INFO = -6 + ELSE IF( ( LWORK.LT.MAX( 1, N*NB ) ) .AND. ( .NOT.LQUERY ) + $ .AND. ( .NOT.LMINWS ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( MINT ) THEN + T( 1 ) = MINTSZ + ELSE + T( 1 ) = NB*N*NBLCKS + 5 + END IF + T( 2 ) = MB + T( 3 ) = NB + IF( MINW ) THEN + WORK( 1 ) = MAX( 1, N ) + ELSE + WORK( 1 ) = MAX( 1, NB*N ) + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N ).EQ.0 ) THEN + RETURN + END IF +* +* The QR Decomposition +* + IF( ( M.LE.N ) .OR. ( MB.LE.N ) .OR. ( MB.GE.M ) ) THEN + CALL DGEQRT( M, N, NB, A, LDA, T( 6 ), NB, WORK, INFO ) + ELSE + CALL DLATSQR( M, N, MB, NB, A, LDA, T( 6 ), NB, WORK, + $ LWORK, INFO ) + END IF +* + WORK( 1 ) = MAX( 1, NB*N ) +* + RETURN +* +* End of DGEQR +* + END diff --git a/math/lapack/src/main/fortran/dgeqr2.f b/math/lapack/src/main/fortran/dgeqr2.f new file mode 100644 index 0000000000..c1e91e9bde --- /dev/null +++ b/math/lapack/src/main/fortran/dgeqr2.f @@ -0,0 +1,192 @@ +*> \brief \b DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEQR2 computes a QR factorization of a real m by n matrix A: +*> A = Q * R. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the m by n matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(m,n) by n upper trapezoidal matrix R (R is +*> upper triangular if m >= n); the elements below the diagonal, +*> with the array TAU, represent the orthogonal matrix Q as a +*> product of elementary reflectors (see Further Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), +*> and tau in TAU(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K + 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/math/lapack/src/main/fortran/dgeqr2p.f b/math/lapack/src/main/fortran/dgeqr2p.f new file mode 100644 index 0000000000..921f799215 --- /dev/null +++ b/math/lapack/src/main/fortran/dgeqr2p.f @@ -0,0 +1,195 @@ +*> \brief \b DGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elements using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQR2P + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEQR2P computes a QR factorization of a real m by n matrix A: +*> A = Q * R. The diagonal entries of R are nonnegative. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the m by n matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(m,n) by n upper trapezoidal matrix R (R is +*> upper triangular if m >= n). The diagonal entries of R are +*> nonnegative; the elements below the diagonal, +*> with the array TAU, represent the orthogonal matrix Q as a +*> product of elementary reflectors (see Further Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), +*> and tau in TAU(i). +*> +*> See Lapack Working Note 203 for details +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K + DOUBLE PRECISION AII +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFGP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQR2P', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = 1, K +* +* Generate elementary reflector H(i) to annihilate A(i+1:m,i) +* + CALL DLARFGP( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, + $ TAU( I ) ) + IF( I.LT.N ) THEN +* +* Apply H(i) to A(i:m,i+1:n) from the left +* + 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 DGEQR2P +* + END diff --git a/math/lapack/src/main/fortran/dgeqrf.f b/math/lapack/src/main/fortran/dgeqrf.f new file mode 100644 index 0000000000..83d7d8dd71 --- /dev/null +++ b/math/lapack/src/main/fortran/dgeqrf.f @@ -0,0 +1,270 @@ +*> \brief \b DGEQRF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEQRF computes a QR factorization of a real M-by-N matrix A: +*> A = Q * R. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(M,N)-by-N upper trapezoidal matrix R (R is +*> upper triangular if m >= n); the elements below the diagonal, +*> with the array TAU, represent the orthogonal matrix Q as a +*> product of min(m,n) elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), +*> and tau in TAU(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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**T 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/math/lapack/src/main/fortran/dgeqrfp.f b/math/lapack/src/main/fortran/dgeqrfp.f new file mode 100644 index 0000000000..d182f98c9d --- /dev/null +++ b/math/lapack/src/main/fortran/dgeqrfp.f @@ -0,0 +1,273 @@ +*> \brief \b DGEQRFP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQRFP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEQRFP computes a QR factorization of a real M-by-N matrix A: +*> A = Q * R. The diagonal entries of R are nonnegative. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(M,N)-by-N upper trapezoidal matrix R (R is +*> upper triangular if m >= n). The diagonal entries of R +*> are nonnegative; the elements below the diagonal, +*> with the array TAU, represent the orthogonal matrix Q as a +*> product of min(m,n) elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), +*> and tau in TAU(i). +*> +*> See Lapack Working Note 203 for details +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DGEQR2P, 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( 'DGEQRFP', -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 DGEQR2P( 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**T 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 DGEQR2P( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* + WORK( 1 ) = IWS + RETURN +* +* End of DGEQRFP +* + END diff --git a/math/lapack/src/main/fortran/dgeqrt.f b/math/lapack/src/main/fortran/dgeqrt.f new file mode 100644 index 0000000000..6856bac07d --- /dev/null +++ b/math/lapack/src/main/fortran/dgeqrt.f @@ -0,0 +1,218 @@ +*> \brief \b DGEQRT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDT, M, N, NB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEQRT computes a blocked QR factorization of a real M-by-N matrix A +*> using the compact WY representation of Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The block size to be used in the blocked QR. MIN(M,N) >= NB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(M,N)-by-N upper trapezoidal matrix R (R is +*> upper triangular if M >= N); the elements below the diagonal +*> are the columns of V. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,MIN(M,N)) +*> The upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See below +*> for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (NB*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix V stores the elementary reflectors H(i) in the i-th column +*> below the diagonal. For example, if M=5 and N=3, the matrix V is +*> +*> V = ( 1 ) +*> ( v1 1 ) +*> ( v1 v2 1 ) +*> ( v1 v2 v3 ) +*> ( v1 v2 v3 ) +*> +*> where the vi's represent the vectors which define H(i), which are returned +*> in the matrix A. The 1's along the diagonal of V are not stored in A. +*> +*> Let K=MIN(M,N). The number of blocks is B = ceiling(K/NB), where each +*> block is of order NB except for the last block, which is of order +*> IB = K - (B-1)*NB. For each of the B blocks, a upper triangular block +*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB +*> for the last block) T's are stored in the NB-by-N matrix T as +*> +*> T = (T1 T2 ... TB). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDT, M, N, NB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I, IB, IINFO, K + LOGICAL USE_RECURSIVE_QR + PARAMETER( USE_RECURSIVE_QR=.TRUE. ) +* .. +* .. External Subroutines .. + EXTERNAL DGEQRT2, DGEQRT3, DLARFB, XERBLA +* .. +* .. 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( NB.LT.1 .OR. ( NB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDT.LT.NB ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQRT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + K = MIN( M, N ) + IF( K.EQ.0 ) RETURN +* +* Blocked loop of length K +* + DO I = 1, K, NB + IB = MIN( K-I+1, NB ) +* +* Compute the QR factorization of the current block A(I:M,I:I+IB-1) +* + IF( USE_RECURSIVE_QR ) THEN + CALL DGEQRT3( M-I+1, IB, A(I,I), LDA, T(1,I), LDT, IINFO ) + ELSE + CALL DGEQRT2( M-I+1, IB, A(I,I), LDA, T(1,I), LDT, IINFO ) + END IF + IF( I+IB.LE.N ) THEN +* +* Update by applying H**T to A(I:M,I+IB:N) from the left +* + CALL DLARFB( 'L', 'T', 'F', 'C', M-I+1, N-I-IB+1, IB, + $ A( I, I ), LDA, T( 1, I ), LDT, + $ A( I, I+IB ), LDA, WORK , N-I-IB+1 ) + END IF + END DO + RETURN +* +* End of DGEQRT +* + END diff --git a/math/lapack/src/main/fortran/dgeqrt2.f b/math/lapack/src/main/fortran/dgeqrt2.f new file mode 100644 index 0000000000..138dd4d9c1 --- /dev/null +++ b/math/lapack/src/main/fortran/dgeqrt2.f @@ -0,0 +1,227 @@ +*> \brief \b DGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY representation of Q. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQRT2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEQRT2( M, N, A, LDA, T, LDT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDT, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( LDT, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEQRT2 computes a QR factorization of a real M-by-N matrix A, +*> using the compact WY representation of Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= N. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the real M-by-N matrix A. On exit, the elements on and +*> above the diagonal contain the N-by-N upper triangular matrix R; the +*> elements below the diagonal are the columns of V. See below for +*> further details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> The N-by-N upper triangular factor of the block reflector. +*> The elements on and above the diagonal contain the block +*> reflector T; the elements below the diagonal are not used. +*> See below for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix V stores the elementary reflectors H(i) in the i-th column +*> below the diagonal. For example, if M=5 and N=3, the matrix V is +*> +*> V = ( 1 ) +*> ( v1 1 ) +*> ( v1 v2 1 ) +*> ( v1 v2 v3 ) +*> ( v1 v2 v3 ) +*> +*> where the vi's represent the vectors which define H(i), which are returned +*> in the matrix A. The 1's along the diagonal of V are not stored in A. The +*> block reflector H is then given by +*> +*> H = I - V * T * V**T +*> +*> where V**T is the transpose of V. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEQRT2( M, N, A, LDA, T, LDT, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDT, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER( ONE = 1.0D+00, ZERO = 0.0D+00 ) +* .. +* .. Local Scalars .. + INTEGER I, K + DOUBLE PRECISION AII, ALPHA +* .. +* .. External Subroutines .. + EXTERNAL DLARFG, DGEMV, DGER, DTRMV, XERBLA +* .. +* .. 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 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQRT2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO I = 1, K +* +* Generate elem. refl. H(i) to annihilate A(i+1:m,i), tau(I) -> T(I,1) +* + CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, + $ T( I, 1 ) ) + 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 +* +* W(1:N-I) := A(I:M,I+1:N)^H * A(I:M,I) [W = T(:,N)] +* + CALL DGEMV( 'T',M-I+1, N-I, ONE, A( I, I+1 ), LDA, + $ A( I, I ), 1, ZERO, T( 1, N ), 1 ) +* +* A(I:M,I+1:N) = A(I:m,I+1:N) + alpha*A(I:M,I)*W(1:N-1)^H +* + ALPHA = -(T( I, 1 )) + CALL DGER( M-I+1, N-I, ALPHA, A( I, I ), 1, + $ T( 1, N ), 1, A( I, I+1 ), LDA ) + A( I, I ) = AII + END IF + END DO +* + DO I = 2, N + AII = A( I, I ) + A( I, I ) = ONE +* +* T(1:I-1,I) := alpha * A(I:M,1:I-1)**T * A(I:M,I) +* + ALPHA = -T( I, 1 ) + CALL DGEMV( 'T', M-I+1, I-1, ALPHA, A( I, 1 ), LDA, + $ A( I, I ), 1, ZERO, T( 1, I ), 1 ) + A( I, I ) = AII +* +* T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) +* + CALL DTRMV( 'U', 'N', 'N', I-1, T, LDT, T( 1, I ), 1 ) +* +* T(I,I) = tau(I) +* + T( I, I ) = T( I, 1 ) + T( I, 1) = ZERO + END DO + +* +* End of DGEQRT2 +* + END diff --git a/math/lapack/src/main/fortran/dgeqrt3.f b/math/lapack/src/main/fortran/dgeqrt3.f new file mode 100644 index 0000000000..efec07850a --- /dev/null +++ b/math/lapack/src/main/fortran/dgeqrt3.f @@ -0,0 +1,257 @@ +*> \brief \b DGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact WY representation of Q. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQRT3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* RECURSIVE SUBROUTINE DGEQRT3( M, N, A, LDA, T, LDT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, LDT +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( LDT, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEQRT3 recursively computes a QR factorization of a real M-by-N +*> matrix A, using the compact WY representation of Q. +*> +*> Based on the algorithm of Elmroth and Gustavson, +*> IBM J. Res. Develop. Vol 44 No. 4 July 2000. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= N. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the real M-by-N matrix A. On exit, the elements on and +*> above the diagonal contain the N-by-N upper triangular matrix R; the +*> elements below the diagonal are the columns of V. See below for +*> further details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> The N-by-N upper triangular factor of the block reflector. +*> The elements on and above the diagonal contain the block +*> reflector T; the elements below the diagonal are not used. +*> See below for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix V stores the elementary reflectors H(i) in the i-th column +*> below the diagonal. For example, if M=5 and N=3, the matrix V is +*> +*> V = ( 1 ) +*> ( v1 1 ) +*> ( v1 v2 1 ) +*> ( v1 v2 v3 ) +*> ( v1 v2 v3 ) +*> +*> where the vi's represent the vectors which define H(i), which are returned +*> in the matrix A. The 1's along the diagonal of V are not stored in A. The +*> block reflector H is then given by +*> +*> H = I - V * T * V**T +*> +*> where V**T is the transpose of V. +*> +*> For details of the algorithm, see Elmroth and Gustavson (cited above). +*> \endverbatim +*> +* ===================================================================== + RECURSIVE SUBROUTINE DGEQRT3( M, N, A, LDA, T, LDT, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, LDT +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+00 ) +* .. +* .. Local Scalars .. + INTEGER I, I1, J, J1, N1, N2, IINFO +* .. +* .. External Subroutines .. + EXTERNAL DLARFG, DTRMM, DGEMM, XERBLA +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( N .LT. 0 ) THEN + INFO = -2 + ELSE IF( M .LT. N ) THEN + INFO = -1 + ELSE IF( LDA .LT. MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( LDT .LT. MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQRT3', -INFO ) + RETURN + END IF +* + IF( N.EQ.1 ) THEN +* +* Compute Householder transform when N=1 +* + CALL DLARFG( M, A(1,1), A( MIN( 2, M ), 1 ), 1, T(1,1) ) +* + ELSE +* +* Otherwise, split A into blocks... +* + N1 = N/2 + N2 = N-N1 + J1 = MIN( N1+1, N ) + I1 = MIN( N+1, M ) +* +* Compute A(1:M,1:N1) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H +* + CALL DGEQRT3( M, N1, A, LDA, T, LDT, IINFO ) +* +* Compute A(1:M,J1:N) = Q1^H A(1:M,J1:N) [workspace: T(1:N1,J1:N)] +* + DO J=1,N2 + DO I=1,N1 + T( I, J+N1 ) = A( I, J+N1 ) + END DO + END DO + CALL DTRMM( 'L', 'L', 'T', 'U', N1, N2, ONE, + & A, LDA, T( 1, J1 ), LDT ) +* + CALL DGEMM( 'T', 'N', N1, N2, M-N1, ONE, A( J1, 1 ), LDA, + & A( J1, J1 ), LDA, ONE, T( 1, J1 ), LDT) +* + CALL DTRMM( 'L', 'U', 'T', 'N', N1, N2, ONE, + & T, LDT, T( 1, J1 ), LDT ) +* + CALL DGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( J1, 1 ), LDA, + & T( 1, J1 ), LDT, ONE, A( J1, J1 ), LDA ) +* + CALL DTRMM( 'L', 'L', 'N', 'U', N1, N2, ONE, + & A, LDA, T( 1, J1 ), LDT ) +* + DO J=1,N2 + DO I=1,N1 + A( I, J+N1 ) = A( I, J+N1 ) - T( I, J+N1 ) + END DO + END DO +* +* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H +* + CALL DGEQRT3( M-N1, N2, A( J1, J1 ), LDA, + & T( J1, J1 ), LDT, IINFO ) +* +* Compute T3 = T(1:N1,J1:N) = -T1 Y1^H Y2 T2 +* + DO I=1,N1 + DO J=1,N2 + T( I, J+N1 ) = (A( J+N1, I )) + END DO + END DO +* + CALL DTRMM( 'R', 'L', 'N', 'U', N1, N2, ONE, + & A( J1, J1 ), LDA, T( 1, J1 ), LDT ) +* + CALL DGEMM( 'T', 'N', N1, N2, M-N, ONE, A( I1, 1 ), LDA, + & A( I1, J1 ), LDA, ONE, T( 1, J1 ), LDT ) +* + CALL DTRMM( 'L', 'U', 'N', 'N', N1, N2, -ONE, T, LDT, + & T( 1, J1 ), LDT ) +* + CALL DTRMM( 'R', 'U', 'N', 'N', N1, N2, ONE, + & T( J1, J1 ), LDT, T( 1, J1 ), LDT ) +* +* Y = (Y1,Y2); R = [ R1 A(1:N1,J1:N) ]; T = [T1 T3] +* [ 0 R2 ] [ 0 T2] +* + END IF +* + RETURN +* +* End of DGEQRT3 +* + END diff --git a/math/lapack/src/main/fortran/dgerfs.f b/math/lapack/src/main/fortran/dgerfs.f new file mode 100644 index 0000000000..a6f14e2b58 --- /dev/null +++ b/math/lapack/src/main/fortran/dgerfs.f @@ -0,0 +1,438 @@ +*> \brief \b DGERFS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGERFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, +* X, LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* .. 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGERFS improves the computed solution to a system of linear +*> equations and provides error bounds and backward error estimates for +*> the solution. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The original N-by-N matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> The factors L and U from the factorization A = P*L*U +*> as computed by DGETRF. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from DGETRF; for 1<=i<=N, row i of the +*> matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> On entry, the solution matrix X, as computed by DGETRS. +*> On exit, the improved solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> ITMAX is the maximum number of steps of iterative refinement. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, + $ X, LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dgerfsx.f b/math/lapack/src/main/fortran/dgerfsx.f new file mode 100644 index 0000000000..aafca8d10d --- /dev/null +++ b/math/lapack/src/main/fortran/dgerfsx.f @@ -0,0 +1,731 @@ +*> \brief \b DGERFSX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGERFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, +* R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, +* ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS, EQUED +* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, +* $ N_ERR_BNDS +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), +* $ X( LDX , * ), WORK( * ) +* DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), +* $ ERR_BNDS_NORM( NRHS, * ), +* $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGERFSX improves the computed solution to a system of linear +*> equations and provides error bounds and backward error estimates +*> for the solution. In addition to normwise error bound, the code +*> provides maximum componentwise error bound if possible. See +*> comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the +*> error bounds. +*> +*> The original system of linear equations may have been equilibrated +*> before calling this routine, as described by arguments EQUED, R +*> and C below. In this case, the solution and error bounds returned +*> are for the original unequilibrated system. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> Some optional parameters are bundled in the PARAMS array. These +*> settings determine how refinement is performed, but often the +*> defaults are acceptable. If the defaults are acceptable, users +*> can pass NPARAMS = 0 which prevents the source code from accessing +*> the PARAMS argument. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] EQUED +*> \verbatim +*> EQUED is CHARACTER*1 +*> Specifies the form of equilibration that was done to A +*> before calling this routine. This is needed to compute +*> the solution and error bounds correctly. +*> = 'N': No equilibration +*> = 'R': Row equilibration, i.e., A has been premultiplied by +*> diag(R). +*> = 'C': Column equilibration, i.e., A has been postmultiplied +*> by diag(C). +*> = 'B': Both row and column equilibration, i.e., A has been +*> replaced by diag(R) * A * diag(C). +*> The right hand side B has been changed accordingly. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The original N-by-N matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> The factors L and U from the factorization A = P*L*U +*> as computed by DGETRF. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from DGETRF; for 1<=i<=N, row i of the +*> matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[in] R +*> \verbatim +*> R is 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. +*> If R is accessed, each element of R should be a power of the radix +*> to ensure a reliable solution and error estimates. Scaling by +*> powers of the radix does not cause rounding errors unless the +*> result underflows or overflows. Rounding errors during scaling +*> lead to refining with a matrix that is not equivalent to the +*> input matrix, producing error estimates that may not be +*> reliable. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is 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. +*> If C is accessed, each element of C should be a power of the radix +*> to ensure a reliable solution and error estimates. Scaling by +*> powers of the radix does not cause rounding errors unless the +*> result underflows or overflows. Rounding errors during scaling +*> lead to refining with a matrix that is not equivalent to the +*> input matrix, producing error estimates that may not be +*> reliable. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> On entry, the solution matrix X, as computed by DGETRS. +*> On exit, the improved solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> Reciprocal scaled condition number. This is an estimate of the +*> reciprocal Skeel condition number of the matrix A after +*> equilibration (if done). If this is less than the machine +*> precision (in particular, if it is zero), the matrix is singular +*> to working precision. Note that the error may still be small even +*> if this number is very small and the matrix appears ill- +*> conditioned. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is DOUBLE PRECISION array, dimension (NRHS) +*> Componentwise relative backward error. This is the +*> componentwise relative backward error of each solution vector X(j) +*> (i.e., the smallest relative change in any element of A or B that +*> makes X(j) an exact solution). +*> \endverbatim +*> +*> \param[in] N_ERR_BNDS +*> \verbatim +*> N_ERR_BNDS is INTEGER +*> Number of error bounds to return for each right hand side +*> and each type (normwise or componentwise). See ERR_BNDS_NORM and +*> ERR_BNDS_COMP below. +*> \endverbatim +*> +*> \param[out] ERR_BNDS_NORM +*> \verbatim +*> ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> normwise relative error, which is defined as follows: +*> +*> Normwise relative error in the ith solution vector: +*> max_j (abs(XTRUE(j,i) - X(j,i))) +*> ------------------------------ +*> max_j abs(X(j,i)) +*> +*> The array is indexed by the type of error information as described +*> below. There currently are up to three pieces of information +*> returned. +*> +*> The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_NORM(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * dlamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * dlamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated normwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * dlamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*A, where S scales each row by a power of the +*> radix so all absolute row sums of Z are approximately 1. +*> +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[out] ERR_BNDS_COMP +*> \verbatim +*> ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> componentwise relative error, which is defined as follows: +*> +*> Componentwise relative error in the ith solution vector: +*> abs(XTRUE(j,i) - X(j,i)) +*> max_j ---------------------- +*> abs(X(j,i)) +*> +*> The array is indexed by the right-hand side i (on which the +*> componentwise relative error depends), and the type of error +*> information as described below. There currently are up to three +*> pieces of information returned for each right-hand side. If +*> componentwise accuracy is not requested (PARAMS(3) = 0.0), then +*> ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +*> the first (:,N_ERR_BNDS) entries are returned. +*> +*> The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_COMP(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * dlamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * dlamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated componentwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * dlamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*(A*diag(x)), where x is the solution for the +*> current right-hand side and S scales each row of +*> A*diag(x) by a power of the radix so all absolute row +*> sums of Z are approximately 1. +*> +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[in] NPARAMS +*> \verbatim +*> NPARAMS is INTEGER +*> Specifies the number of parameters set in PARAMS. If .LE. 0, the +*> PARAMS array is never referenced and default values are used. +*> \endverbatim +*> +*> \param[in,out] PARAMS +*> \verbatim +*> PARAMS is DOUBLE PRECISION array, dimension (NPARAMS) +*> Specifies algorithm parameters. If an entry is .LT. 0.0, then +*> that entry will be filled with default value used for that +*> parameter. Only positions up to NPARAMS are accessed; defaults +*> are used for higher-numbered parameters. +*> +*> PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +*> refinement or not. +*> Default: 1.0D+0 +*> = 0.0 : No refinement is performed, and no error bounds are +*> computed. +*> = 1.0 : Use the double-precision refinement algorithm, +*> possibly with doubled-single computations if the +*> compilation environment does not support DOUBLE +*> PRECISION. +*> (other values are reserved for future use) +*> +*> PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +*> computations allowed for refinement. +*> Default: 10 +*> Aggressive: Set to 100 to permit convergence using approximate +*> factorizations or factorizations other than LU. If +*> the factorization uses a technique other than +*> Gaussian elimination, the guarantees in +*> err_bnds_norm and err_bnds_comp may no longer be +*> trustworthy. +*> +*> PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +*> will attempt to find a solution with small componentwise +*> relative error in the double-precision algorithm. Positive +*> is true, 0.0 is false. +*> Default: 1.0 (attempt componentwise convergence) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Successful exit. The solution to every right-hand side is +*> guaranteed. +*> < 0: If INFO = -i, the i-th argument had an illegal value +*> > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +*> has been completed, but the factor U is exactly singular, so +*> the solution and error bounds could not be computed. RCOND = 0 +*> is returned. +*> = N+J: The solution corresponding to the Jth right-hand side is +*> not guaranteed. The solutions corresponding to other right- +*> hand sides K with K > J may not be guaranteed as well, but +*> only the first such right-hand side is reported. If a small +*> componentwise error is not requested (PARAMS(3) = 0.0) then +*> the Jth right-hand side is the first with a normwise error +*> bound that is not guaranteed (the smallest J such +*> that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +*> the Jth right-hand side is the first with either a normwise or +*> componentwise error bound that is not guaranteed (the smallest +*> J such that either ERR_BNDS_NORM(J,1) = 0.0 or +*> ERR_BNDS_COMP(J,1) = 0.0). See the definition of +*> ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +*> about all of the right-hand sides check ERR_BNDS_NORM or +*> ERR_BNDS_COMP. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE DGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANS, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX , * ), WORK( * ) + DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT + DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT + DOUBLE PRECISION DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0D+0 ) + PARAMETER ( ITHRESH_DEFAULT = 10.0D+0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0D+0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5D+0 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25D+0 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL ROWEQU, COLEQU, NOTRAN + INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + DOUBLE PRECISION ANORM, RCOND_TMP + DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DGECON, DLA_GERFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, ILATRANS, ILAPREC + EXTERNAL DLAMCH, DLANGE, DLA_GERCOND + DOUBLE PRECISION DLAMCH, DLANGE, DLA_GERCOND + LOGICAL LSAME + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + TRANS_TYPE = ILATRANS( TRANS ) + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0D+0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = DBLE( N ) * DLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0D+0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0D+0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0D+0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0D+0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0D+0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0D+0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + NOTRAN = LSAME( TRANS, 'N' ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) +* +* Test input parameters. +* + IF( TRANS_TYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( .NOT.ROWEQU .AND. .NOT.COLEQU .AND. + $ .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGERFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0D+0 + DO J = 1, NRHS + BERR( J ) = 0.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF + IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0D+0 + END IF + IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0D+0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0D+0 + DO J = 1, NRHS + BERR( J ) = 1.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF + IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + END IF + IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0D+0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + IF( NOTRAN ) THEN + NORM = 'I' + ELSE + NORM = '1' + END IF + ANORM = DLANGE( NORM, N, N, A, LDA, WORK ) + CALL DGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'E' ) + + IF ( NOTRAN ) THEN + CALL DLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK(N+1), WORK(1), WORK(2*N+1), + $ WORK(1), RCOND, ITHRESH, RTHRESH, UNSTABLE_THRESH, + $ IGNORE_CWISE, INFO ) + ELSE + CALL DLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, ROWEQU, R, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK(N+1), WORK(1), WORK(2*N+1), + $ WORK(1), RCOND, ITHRESH, RTHRESH, UNSTABLE_THRESH, + $ IGNORE_CWISE, INFO ) + END IF + END IF + + ERR_LBND = MAX( 10.0D+0, SQRT( DBLE( N ) ) ) * DLAMCH( 'Epsilon' ) + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1 ) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( COLEQU .AND. NOTRAN ) THEN + RCOND_TMP = DLA_GERCOND( TRANS, N, A, LDA, AF, LDAF, IPIV, + $ -1, C, INFO, WORK, IWORK ) + ELSE IF ( ROWEQU .AND. .NOT. NOTRAN ) THEN + RCOND_TMP = DLA_GERCOND( TRANS, N, A, LDA, AF, LDAF, IPIV, + $ -1, R, INFO, WORK, IWORK ) + ELSE + RCOND_TMP = DLA_GERCOND( TRANS, N, A, LDA, AF, LDAF, IPIV, + $ 0, R, INFO, WORK, IWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF + + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2 ) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( DLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = DLA_GERCOND( TRANS, N, A, LDA, AF, LDAF, + $ IPIV, 1, X(1,J), INFO, WORK, IWORK ) + ELSE + RCOND_TMP = 0.0D+0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0D+0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF +* + RETURN +* +* End of DGERFSX +* + END diff --git a/math/lapack/src/main/fortran/dgerq2.f b/math/lapack/src/main/fortran/dgerq2.f new file mode 100644 index 0000000000..b1713c1fb7 --- /dev/null +++ b/math/lapack/src/main/fortran/dgerq2.f @@ -0,0 +1,193 @@ +*> \brief \b DGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGERQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGERQ2 computes an RQ factorization of a real m by n matrix A: +*> A = R * Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(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). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K + 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/math/lapack/src/main/fortran/dgerqf.f b/math/lapack/src/main/fortran/dgerqf.f new file mode 100644 index 0000000000..20f2668ef8 --- /dev/null +++ b/math/lapack/src/main/fortran/dgerqf.f @@ -0,0 +1,287 @@ +*> \brief \b DGERQF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGERQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGERQF computes an RQ factorization of a real M-by-N matrix A: +*> A = R * Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(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). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dgesc2.f b/math/lapack/src/main/fortran/dgesc2.f new file mode 100644 index 0000000000..db684bae4a --- /dev/null +++ b/math/lapack/src/main/fortran/dgesc2.f @@ -0,0 +1,201 @@ +*> \brief \b DGESC2 solves a system of linear equations using the LU factorization with complete pivoting computed by sgetc2. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGESC2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) +* +* .. Scalar Arguments .. +* INTEGER LDA, N +* DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), JPIV( * ) +* DOUBLE PRECISION A( LDA, * ), RHS( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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 +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1, N). +*> \endverbatim +*> +*> \param[in,out] RHS +*> \verbatim +*> RHS is DOUBLE PRECISION array, dimension (N). +*> On entry, the right hand side vector b. +*> On exit, the solution vector X. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N). +*> The pivot indices; for 1 <= i <= N, row i of the +*> matrix has been interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[in] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N). +*> The pivot indices; for 1 <= j <= N, column j of the +*> matrix has been interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION +*> On exit, SCALE contains the scale factor. SCALE is chosen +*> 0 <= SCALE <= 1 to prevent owerflow in the solution. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEauxiliary +* +*> \par Contributors: +* ================== +*> +*> Bo Kagstrom and Peter Poromaa, Department of Computing Science, +*> Umea University, S-901 87 Umea, Sweden. +* +* ===================================================================== + SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER LDA, N + DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ), RHS( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dgesdd.f b/math/lapack/src/main/fortran/dgesdd.f new file mode 100644 index 0000000000..926607f983 --- /dev/null +++ b/math/lapack/src/main/fortran/dgesdd.f @@ -0,0 +1,1548 @@ +*> \brief \b DGESDD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGESDD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, +* WORK, LWORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ +* INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), +* $ VT( LDVT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGESDD computes the singular value decomposition (SVD) of a real +*> M-by-N matrix A, optionally computing the left and right singular +*> vectors. If singular vectors are desired, it uses a +*> divide-and-conquer algorithm. +*> +*> The SVD is written +*> +*> A = U * SIGMA * transpose(V) +*> +*> where SIGMA is an M-by-N matrix which is zero except for its +*> min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and +*> V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA +*> are the singular values of A; they are real and non-negative, and +*> are returned in descending order. The first min(m,n) columns of +*> U and V are the left and right singular vectors of A. +*> +*> Note that the routine returns VT = V**T, not V. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> Specifies options for computing all or part of the matrix U: +*> = 'A': all M columns of U and all N rows of V**T are +*> returned in the arrays U and VT; +*> = 'S': the first min(M,N) columns of U and the first +*> min(M,N) rows of V**T are returned in the arrays U +*> and VT; +*> = 'O': If M >= N, the first N columns of U are overwritten +*> on the array A and all rows of V**T are returned in +*> the array VT; +*> otherwise, all columns of U are returned in the +*> array U and the first M rows of V**T are overwritten +*> in the array A; +*> = 'N': no columns of U or rows of V**T are computed. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the input matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the input matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, +*> if JOBZ = 'O', A is overwritten with the first N columns +*> of U (the left singular vectors, stored +*> columnwise) if M >= N; +*> A is overwritten with the first M rows +*> of V**T (the right singular vectors, stored +*> rowwise) otherwise. +*> if JOBZ .ne. 'O', the contents of A are destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (min(M,N)) +*> The singular values of A, sorted so that S(i) >= S(i+1). +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension (LDU,UCOL) +*> UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N; +*> UCOL = min(M,N) if JOBZ = 'S'. +*> If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M +*> orthogonal matrix U; +*> if JOBZ = 'S', U contains the first min(M,N) columns of U +*> (the left singular vectors, stored columnwise); +*> if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of the array U. LDU >= 1; if +*> JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M. +*> \endverbatim +*> +*> \param[out] VT +*> \verbatim +*> VT is DOUBLE PRECISION array, dimension (LDVT,N) +*> If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the +*> N-by-N orthogonal matrix V**T; +*> if JOBZ = 'S', VT contains the first min(M,N) rows of +*> V**T (the right singular vectors, stored rowwise); +*> if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced. +*> \endverbatim +*> +*> \param[in] LDVT +*> \verbatim +*> LDVT is INTEGER +*> The leading dimension of the array VT. LDVT >= 1; +*> if JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; +*> if JOBZ = 'S', LDVT >= min(M,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK; +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 1. +*> If LWORK = -1, a workspace query is assumed. The optimal +*> size for the WORK array is calculated and stored in WORK(1), +*> and no other work except argument checking is performed. +*> +*> Let mx = max(M,N) and mn = min(M,N). +*> If JOBZ = 'N', LWORK >= 3*mn + max( mx, 7*mn ). +*> If JOBZ = 'O', LWORK >= 3*mn + max( mx, 5*mn*mn + 4*mn ). +*> If JOBZ = 'S', LWORK >= 4*mn*mn + 7*mn. +*> If JOBZ = 'A', LWORK >= 4*mn*mn + 6*mn + mx. +*> These are not tight minimums in all cases; see comments inside code. +*> For good performance, LWORK should generally be larger; +*> a query is recommended. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (8*min(M,N)) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: DBDSDC did not converge, updating process failed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleGEsing +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, IWORK, INFO ) + implicit none +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ + INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), + $ VT( LDVT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS + INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IL, + $ IR, ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT, + $ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK, + $ MNTHR, NWORK, WRKBL + INTEGER LWORK_DGEBRD_MN, LWORK_DGEBRD_MM, + $ LWORK_DGEBRD_NN, LWORK_DGELQF_MN, + $ LWORK_DGEQRF_MN, + $ LWORK_DORGBR_P_MM, LWORK_DORGBR_Q_NN, + $ LWORK_DORGLQ_MN, LWORK_DORGLQ_NN, + $ LWORK_DORGQR_MM, LWORK_DORGQR_MN, + $ LWORK_DORMBR_PRT_MM, LWORK_DORMBR_QLN_MM, + $ LWORK_DORMBR_PRT_MN, LWORK_DORMBR_QLN_MN, + $ LWORK_DORMBR_PRT_NN, LWORK_DORMBR_QLN_NN + DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM +* .. +* .. Local Arrays .. + INTEGER IDUM( 1 ) + DOUBLE PRECISION DUM( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DBDSDC, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY, + $ DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + MINMN = MIN( M, N ) + WNTQA = LSAME( JOBZ, 'A' ) + WNTQS = LSAME( JOBZ, 'S' ) + WNTQAS = WNTQA .OR. WNTQS + WNTQO = LSAME( JOBZ, 'O' ) + WNTQN = LSAME( JOBZ, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* + IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR. + $ ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN + INFO = -8 + ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR. + $ ( WNTQS .AND. LDVT.LT.MINMN ) .OR. + $ ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN + INFO = -10 + END IF +* +* Compute workspace +* Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace allocated 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 + BDSPAC = 0 + MNTHR = INT( MINMN*11.0D0 / 6.0D0 ) + IF( M.GE.N .AND. MINMN.GT.0 ) THEN +* +* Compute space needed for DBDSDC +* + IF( WNTQN ) THEN +* dbdsdc needs only 4*N (or 6*N for uplo=L for LAPACK <= 3.6) +* keep 7*N for backwards compatability. + BDSPAC = 7*N + ELSE + BDSPAC = 3*N*N + 4*N + END IF +* +* Compute space preferred for each routine + CALL DGEBRD( M, N, DUM(1), M, DUM(1), DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, IERR ) + LWORK_DGEBRD_MN = INT( DUM(1) ) +* + CALL DGEBRD( N, N, DUM(1), N, DUM(1), DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, IERR ) + LWORK_DGEBRD_NN = INT( DUM(1) ) +* + CALL DGEQRF( M, N, DUM(1), M, DUM(1), DUM(1), -1, IERR ) + LWORK_DGEQRF_MN = INT( DUM(1) ) +* + CALL DORGBR( 'Q', N, N, N, DUM(1), N, DUM(1), DUM(1), -1, + $ IERR ) + LWORK_DORGBR_Q_NN = INT( DUM(1) ) +* + CALL DORGQR( M, M, N, DUM(1), M, DUM(1), DUM(1), -1, IERR ) + LWORK_DORGQR_MM = INT( DUM(1) ) +* + CALL DORGQR( M, N, N, DUM(1), M, DUM(1), DUM(1), -1, IERR ) + LWORK_DORGQR_MN = INT( DUM(1) ) +* + CALL DORMBR( 'P', 'R', 'T', N, N, N, DUM(1), N, + $ DUM(1), DUM(1), N, DUM(1), -1, IERR ) + LWORK_DORMBR_PRT_NN = INT( DUM(1) ) +* + CALL DORMBR( 'Q', 'L', 'N', N, N, N, DUM(1), N, + $ DUM(1), DUM(1), N, DUM(1), -1, IERR ) + LWORK_DORMBR_QLN_NN = INT( DUM(1) ) +* + CALL DORMBR( 'Q', 'L', 'N', M, N, N, DUM(1), M, + $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) + LWORK_DORMBR_QLN_MN = INT( DUM(1) ) +* + CALL DORMBR( 'Q', 'L', 'N', M, M, N, DUM(1), M, + $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) + LWORK_DORMBR_QLN_MM = INT( DUM(1) ) +* + IF( M.GE.MNTHR ) THEN + IF( WNTQN ) THEN +* +* Path 1 (M >> N, JOBZ='N') +* + WRKBL = N + LWORK_DGEQRF_MN + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD_NN ) + MAXWRK = MAX( WRKBL, BDSPAC + N ) + MINWRK = BDSPAC + N + ELSE IF( WNTQO ) THEN +* +* Path 2 (M >> N, JOBZ='O') +* + WRKBL = N + LWORK_DGEQRF_MN + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_MN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) + WRKBL = MAX( WRKBL, 3*N + BDSPAC ) + MAXWRK = WRKBL + 2*N*N + MINWRK = BDSPAC + 2*N*N + 3*N + ELSE IF( WNTQS ) THEN +* +* Path 3 (M >> N, JOBZ='S') +* + WRKBL = N + LWORK_DGEQRF_MN + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_MN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) + WRKBL = MAX( WRKBL, 3*N + BDSPAC ) + MAXWRK = WRKBL + N*N + MINWRK = BDSPAC + N*N + 3*N + ELSE IF( WNTQA ) THEN +* +* Path 4 (M >> N, JOBZ='A') +* + WRKBL = N + LWORK_DGEQRF_MN + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_MM ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) + WRKBL = MAX( WRKBL, 3*N + BDSPAC ) + MAXWRK = WRKBL + N*N + MINWRK = N*N + MAX( 3*N + BDSPAC, N + M ) + END IF + ELSE +* +* Path 5 (M >= N, but not much larger) +* + WRKBL = 3*N + LWORK_DGEBRD_MN + IF( WNTQN ) THEN +* Path 5n (M >= N, jobz='N') + MAXWRK = MAX( WRKBL, 3*N + BDSPAC ) + MINWRK = 3*N + MAX( M, BDSPAC ) + ELSE IF( WNTQO ) THEN +* Path 5o (M >= N, jobz='O') + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_MN ) + WRKBL = MAX( WRKBL, 3*N + BDSPAC ) + MAXWRK = WRKBL + M*N + MINWRK = 3*N + MAX( M, N*N + BDSPAC ) + ELSE IF( WNTQS ) THEN +* Path 5s (M >= N, jobz='S') + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_MN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) + MAXWRK = MAX( WRKBL, 3*N + BDSPAC ) + MINWRK = 3*N + MAX( M, BDSPAC ) + ELSE IF( WNTQA ) THEN +* Path 5a (M >= N, jobz='A') + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) + MAXWRK = MAX( WRKBL, 3*N + BDSPAC ) + MINWRK = 3*N + MAX( M, BDSPAC ) + END IF + END IF + ELSE IF( MINMN.GT.0 ) THEN +* +* Compute space needed for DBDSDC +* + IF( WNTQN ) THEN +* dbdsdc needs only 4*N (or 6*N for uplo=L for LAPACK <= 3.6) +* keep 7*N for backwards compatability. + BDSPAC = 7*M + ELSE + BDSPAC = 3*M*M + 4*M + END IF +* +* Compute space preferred for each routine + CALL DGEBRD( M, N, DUM(1), M, DUM(1), DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, IERR ) + LWORK_DGEBRD_MN = INT( DUM(1) ) +* + CALL DGEBRD( M, M, A, M, S, DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, IERR ) + LWORK_DGEBRD_MM = INT( DUM(1) ) +* + CALL DGELQF( M, N, A, M, DUM(1), DUM(1), -1, IERR ) + LWORK_DGELQF_MN = INT( DUM(1) ) +* + CALL DORGLQ( N, N, M, DUM(1), N, DUM(1), DUM(1), -1, IERR ) + LWORK_DORGLQ_NN = INT( DUM(1) ) +* + CALL DORGLQ( M, N, M, A, M, DUM(1), DUM(1), -1, IERR ) + LWORK_DORGLQ_MN = INT( DUM(1) ) +* + CALL DORGBR( 'P', M, M, M, A, N, DUM(1), DUM(1), -1, IERR ) + LWORK_DORGBR_P_MM = INT( DUM(1) ) +* + CALL DORMBR( 'P', 'R', 'T', M, M, M, DUM(1), M, + $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) + LWORK_DORMBR_PRT_MM = INT( DUM(1) ) +* + CALL DORMBR( 'P', 'R', 'T', M, N, M, DUM(1), M, + $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) + LWORK_DORMBR_PRT_MN = INT( DUM(1) ) +* + CALL DORMBR( 'P', 'R', 'T', N, N, M, DUM(1), N, + $ DUM(1), DUM(1), N, DUM(1), -1, IERR ) + LWORK_DORMBR_PRT_NN = INT( DUM(1) ) +* + CALL DORMBR( 'Q', 'L', 'N', M, M, M, DUM(1), M, + $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) + LWORK_DORMBR_QLN_MM = INT( DUM(1) ) +* + IF( N.GE.MNTHR ) THEN + IF( WNTQN ) THEN +* +* Path 1t (N >> M, JOBZ='N') +* + WRKBL = M + LWORK_DGELQF_MN + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD_MM ) + MAXWRK = MAX( WRKBL, BDSPAC + M ) + MINWRK = BDSPAC + M + ELSE IF( WNTQO ) THEN +* +* Path 2t (N >> M, JOBZ='O') +* + WRKBL = M + LWORK_DGELQF_MN + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_MN ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_MM ) + WRKBL = MAX( WRKBL, 3*M + BDSPAC ) + MAXWRK = WRKBL + 2*M*M + MINWRK = BDSPAC + 2*M*M + 3*M + ELSE IF( WNTQS ) THEN +* +* Path 3t (N >> M, JOBZ='S') +* + WRKBL = M + LWORK_DGELQF_MN + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_MN ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_MM ) + WRKBL = MAX( WRKBL, 3*M + BDSPAC ) + MAXWRK = WRKBL + M*M + MINWRK = BDSPAC + M*M + 3*M + ELSE IF( WNTQA ) THEN +* +* Path 4t (N >> M, JOBZ='A') +* + WRKBL = M + LWORK_DGELQF_MN + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_NN ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_MM ) + WRKBL = MAX( WRKBL, 3*M + BDSPAC ) + MAXWRK = WRKBL + M*M + MINWRK = M*M + MAX( 3*M + BDSPAC, M + N ) + END IF + ELSE +* +* Path 5t (N > M, but not much larger) +* + WRKBL = 3*M + LWORK_DGEBRD_MN + IF( WNTQN ) THEN +* Path 5tn (N > M, jobz='N') + MAXWRK = MAX( WRKBL, 3*M + BDSPAC ) + MINWRK = 3*M + MAX( N, BDSPAC ) + ELSE IF( WNTQO ) THEN +* Path 5to (N > M, jobz='O') + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_MN ) + WRKBL = MAX( WRKBL, 3*M + BDSPAC ) + MAXWRK = WRKBL + M*N + MINWRK = 3*M + MAX( N, M*M + BDSPAC ) + ELSE IF( WNTQS ) THEN +* Path 5ts (N > M, jobz='S') + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_MN ) + MAXWRK = MAX( WRKBL, 3*M + BDSPAC ) + MINWRK = 3*M + MAX( N, BDSPAC ) + ELSE IF( WNTQA ) THEN +* Path 5ta (N > M, jobz='A') + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_NN ) + MAXWRK = MAX( WRKBL, 3*M + BDSPAC ) + MINWRK = 3*M + MAX( N, BDSPAC ) + END IF + END IF + END IF + + MAXWRK = MAX( MAXWRK, MINWRK ) + WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGESDD', -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( WNTQN ) THEN +* +* Path 1 (M >> N, JOBZ='N') +* No singular vectors to be computed +* + ITAU = 1 + NWORK = ITAU + N +* +* Compute A=Q*R +* Workspace: need N [tau] + N [work] +* Workspace: prefer N [tau] + N*NB [work] +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK - NWORK + 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 + NWORK = ITAUP + N +* +* Bidiagonalize R in A +* Workspace: need 3*N [e, tauq, taup] + N [work] +* Workspace: prefer 3*N [e, tauq, taup] + 2*N*NB [work] +* + CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, + $ IERR ) + NWORK = IE + N +* +* Perform bidiagonal SVD, computing singular values only +* Workspace: need N [e] + BDSPAC +* + CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1, + $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) +* + ELSE IF( WNTQO ) THEN +* +* Path 2 (M >> N, JOBZ = 'O') +* N left singular vectors to be overwritten on A and +* N right singular vectors to be computed in VT +* + IR = 1 +* +* WORK(IR) is LDWRKR by N +* + IF( LWORK .GE. LDA*N + N*N + 3*N + BDSPAC ) THEN + LDWRKR = LDA + ELSE + LDWRKR = ( LWORK - N*N - 3*N - BDSPAC ) / N + END IF + ITAU = IR + LDWRKR*N + NWORK = ITAU + N +* +* Compute A=Q*R +* Workspace: need N*N [R] + N [tau] + N [work] +* Workspace: prefer N*N [R] + N [tau] + N*NB [work] +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK - NWORK + 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 [R] + N [tau] + N [work] +* Workspace: prefer N*N [R] + N [tau] + N*NB [work] +* + CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) + IE = ITAU + ITAUQ = IE + N + ITAUP = ITAUQ + N + NWORK = ITAUP + N +* +* Bidiagonalize R in WORK(IR) +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N [work] +* Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + 2*N*NB [work] +* + CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) +* +* WORK(IU) is N by N +* + IU = NWORK + NWORK = IU + N*N +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in WORK(IU) and computing right +* singular vectors of bidiagonal matrix in VT +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N*N [U] + BDSPAC +* + CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N, + $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK, + $ INFO ) +* +* Overwrite WORK(IU) by left singular vectors of R +* and VT by right singular vectors of R +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N*N [U] + N [work] +* Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + N*N [U] + N*NB [work] +* + CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUQ ), WORK( IU ), N, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) + CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) +* +* Multiply Q in A by left singular vectors of R in +* WORK(IU), storing result in WORK(IR) and copying to A +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N*N [U] +* Workspace: prefer M*N [R] + 3*N [e, tauq, taup] + N*N [U] +* + DO 10 I = 1, M, LDWRKR + CHUNK = MIN( M - I + 1, LDWRKR ) + CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), + $ LDA, WORK( IU ), N, ZERO, WORK( IR ), + $ LDWRKR ) + CALL DLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR, + $ A( I, 1 ), LDA ) + 10 CONTINUE +* + ELSE IF( WNTQS ) THEN +* +* Path 3 (M >> N, JOBZ='S') +* N left singular vectors to be computed in U and +* N right singular vectors to be computed in VT +* + IR = 1 +* +* WORK(IR) is N by N +* + LDWRKR = N + ITAU = IR + LDWRKR*N + NWORK = ITAU + N +* +* Compute A=Q*R +* Workspace: need N*N [R] + N [tau] + N [work] +* Workspace: prefer N*N [R] + N [tau] + N*NB [work] +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK - NWORK + 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 [R] + N [tau] + N [work] +* Workspace: prefer N*N [R] + N [tau] + N*NB [work] +* + CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) + IE = ITAU + ITAUQ = IE + N + ITAUP = ITAUQ + N + NWORK = ITAUP + N +* +* Bidiagonalize R in WORK(IR) +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N [work] +* Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + 2*N*NB [work] +* + CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagoal matrix in U and computing right singular +* vectors of bidiagonal matrix in VT +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + BDSPAC +* + CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, + $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, + $ INFO ) +* +* Overwrite U by left singular vectors of R and VT +* by right singular vectors of R +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N [work] +* Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + N*NB [work] +* + CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) +* + CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) +* +* Multiply Q in A by left singular vectors of R in +* WORK(IR), storing result in U +* Workspace: need N*N [R] +* + CALL DLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR ) + CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, WORK( IR ), + $ LDWRKR, ZERO, U, LDU ) +* + ELSE IF( WNTQA ) THEN +* +* Path 4 (M >> N, JOBZ='A') +* M left singular vectors to be computed in U and +* N right singular vectors to be computed in VT +* + IU = 1 +* +* WORK(IU) is N by N +* + LDWRKU = N + ITAU = IU + LDWRKU*N + NWORK = ITAU + N +* +* Compute A=Q*R, copying result to U +* Workspace: need N*N [U] + N [tau] + N [work] +* Workspace: prefer N*N [U] + N [tau] + N*NB [work] +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) + CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* Workspace: need N*N [U] + N [tau] + M [work] +* Workspace: prefer N*N [U] + N [tau] + M*NB [work] + CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) +* +* Produce R in A, zeroing out other entries +* + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) + IE = ITAU + ITAUQ = IE + N + ITAUP = ITAUQ + N + NWORK = ITAUP + N +* +* Bidiagonalize R in A +* Workspace: need N*N [U] + 3*N [e, tauq, taup] + N [work] +* Workspace: prefer N*N [U] + 3*N [e, tauq, taup] + 2*N*NB [work] +* + CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, + $ IERR ) +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in WORK(IU) and computing right +* singular vectors of bidiagonal matrix in VT +* Workspace: need N*N [U] + 3*N [e, tauq, taup] + BDSPAC +* + CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N, + $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK, + $ INFO ) +* +* Overwrite WORK(IU) by left singular vectors of R and VT +* by right singular vectors of R +* Workspace: need N*N [U] + 3*N [e, tauq, taup] + N [work] +* Workspace: prefer N*N [U] + 3*N [e, tauq, taup] + N*NB [work] +* + CALL DORMBR( 'Q', 'L', 'N', N, N, N, A, LDA, + $ WORK( ITAUQ ), WORK( IU ), LDWRKU, + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) + CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) +* +* Multiply Q in U by left singular vectors of R in +* WORK(IU), storing result in A +* Workspace: need N*N [U] +* + 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 ) +* + END IF +* + ELSE +* +* M .LT. MNTHR +* +* Path 5 (M >= N, but not much larger) +* Reduce to bidiagonal form without QR decomposition +* + IE = 1 + ITAUQ = IE + N + ITAUP = ITAUQ + N + NWORK = ITAUP + N +* +* Bidiagonalize A +* Workspace: need 3*N [e, tauq, taup] + M [work] +* Workspace: prefer 3*N [e, tauq, taup] + (M+N)*NB [work] +* + CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, + $ IERR ) + IF( WNTQN ) THEN +* +* Path 5n (M >= N, JOBZ='N') +* Perform bidiagonal SVD, only computing singular values +* Workspace: need 3*N [e, tauq, taup] + BDSPAC +* + CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1, + $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) + ELSE IF( WNTQO ) THEN +* Path 5o (M >= N, JOBZ='O') + IU = NWORK + IF( LWORK .GE. M*N + 3*N + BDSPAC ) THEN +* +* WORK( IU ) is M by N +* + LDWRKU = M + NWORK = IU + LDWRKU*N + CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IU ), + $ LDWRKU ) +* IR is unused; silence compile warnings + IR = -1 + ELSE +* +* WORK( IU ) is N by N +* + LDWRKU = N + NWORK = IU + LDWRKU*N +* +* WORK(IR) is LDWRKR by N +* + IR = NWORK + LDWRKR = ( LWORK - N*N - 3*N ) / N + END IF + NWORK = IU + LDWRKU*N +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in WORK(IU) and computing right +* singular vectors of bidiagonal matrix in VT +* Workspace: need 3*N [e, tauq, taup] + N*N [U] + BDSPAC +* + CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), + $ LDWRKU, VT, LDVT, DUM, IDUM, WORK( NWORK ), + $ IWORK, INFO ) +* +* Overwrite VT by right singular vectors of A +* Workspace: need 3*N [e, tauq, taup] + N*N [U] + N [work] +* Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + N*NB [work] +* + CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) +* + IF( LWORK .GE. M*N + 3*N + BDSPAC ) THEN +* +* Path 5o-fast +* Overwrite WORK(IU) by left singular vectors of A +* Workspace: need 3*N [e, tauq, taup] + M*N [U] + N [work] +* Workspace: prefer 3*N [e, tauq, taup] + M*N [U] + N*NB [work] +* + CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA, + $ WORK( ITAUQ ), WORK( IU ), LDWRKU, + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) +* +* Copy left singular vectors of A from WORK(IU) to A +* + CALL DLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA ) + ELSE +* +* Path 5o-slow +* Generate Q in A +* Workspace: need 3*N [e, tauq, taup] + N*N [U] + N [work] +* Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + N*NB [work] +* + CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) +* +* Multiply Q in A by left singular vectors of +* bidiagonal matrix in WORK(IU), storing result in +* WORK(IR) and copying to A +* Workspace: need 3*N [e, tauq, taup] + N*N [U] + NB*N [R] +* Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + M*N [R] +* + DO 20 I = 1, M, LDWRKR + CHUNK = MIN( M - I + 1, LDWRKR ) + CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), + $ LDA, WORK( IU ), LDWRKU, ZERO, + $ WORK( IR ), LDWRKR ) + CALL DLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR, + $ A( I, 1 ), LDA ) + 20 CONTINUE + END IF +* + ELSE IF( WNTQS ) THEN +* +* Path 5s (M >= N, JOBZ='S') +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in U and computing right singular +* vectors of bidiagonal matrix in VT +* Workspace: need 3*N [e, tauq, taup] + BDSPAC +* + CALL DLASET( 'F', M, N, ZERO, ZERO, U, LDU ) + CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, + $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, + $ INFO ) +* +* Overwrite U by left singular vectors of A and VT +* by right singular vectors of A +* Workspace: need 3*N [e, tauq, taup] + N [work] +* Workspace: prefer 3*N [e, tauq, taup] + N*NB [work] +* + CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) + CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) + ELSE IF( WNTQA ) THEN +* +* Path 5a (M >= N, JOBZ='A') +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in U and computing right singular +* vectors of bidiagonal matrix in VT +* Workspace: need 3*N [e, tauq, taup] + BDSPAC +* + CALL DLASET( 'F', M, M, ZERO, ZERO, U, LDU ) + CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, + $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, + $ INFO ) +* +* Set the right corner of U to identity matrix +* + IF( M.GT.N ) THEN + CALL DLASET( 'F', M - N, M - N, ZERO, ONE, U(N+1,N+1), + $ LDU ) + END IF +* +* Overwrite U by left singular vectors of A and VT +* by right singular vectors of A +* Workspace: need 3*N [e, tauq, taup] + M [work] +* Workspace: prefer 3*N [e, tauq, taup] + M*NB [work] +* + CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) + CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) + 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( WNTQN ) THEN +* +* Path 1t (N >> M, JOBZ='N') +* No singular vectors to be computed +* + ITAU = 1 + NWORK = ITAU + M +* +* Compute A=L*Q +* Workspace: need M [tau] + M [work] +* Workspace: prefer M [tau] + M*NB [work] +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK - NWORK + 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 + NWORK = ITAUP + M +* +* Bidiagonalize L in A +* Workspace: need 3*M [e, tauq, taup] + M [work] +* Workspace: prefer 3*M [e, tauq, taup] + 2*M*NB [work] +* + CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, + $ IERR ) + NWORK = IE + M +* +* Perform bidiagonal SVD, computing singular values only +* Workspace: need M [e] + BDSPAC +* + CALL DBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1, + $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) +* + ELSE IF( WNTQO ) THEN +* +* Path 2t (N >> M, JOBZ='O') +* M right singular vectors to be overwritten on A and +* M left singular vectors to be computed in U +* + IVT = 1 +* +* WORK(IVT) is M by M +* WORK(IL) is M by M; it is later resized to M by chunk for gemm +* + IL = IVT + M*M + IF( LWORK .GE. M*N + M*M + 3*M + BDSPAC ) THEN + LDWRKL = M + CHUNK = N + ELSE + LDWRKL = M + CHUNK = ( LWORK - M*M ) / M + END IF + ITAU = IL + LDWRKL*M + NWORK = ITAU + M +* +* Compute A=L*Q +* Workspace: need M*M [VT] + M*M [L] + M [tau] + M [work] +* Workspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work] +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) +* +* Copy L to WORK(IL), zeroing about above it +* + CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL ) + CALL DLASET( 'U', M - 1, M - 1, ZERO, ZERO, + $ WORK( IL + LDWRKL ), LDWRKL ) +* +* Generate Q in A +* Workspace: need M*M [VT] + M*M [L] + M [tau] + M [work] +* Workspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work] +* + CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) + IE = ITAU + ITAUQ = IE + M + ITAUP = ITAUQ + M + NWORK = ITAUP + M +* +* Bidiagonalize L in WORK(IL) +* Workspace: need M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M [work] +* Workspace: prefer M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + 2*M*NB [work] +* + CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in U, and computing right singular +* vectors of bidiagonal matrix in WORK(IVT) +* Workspace: need M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + BDSPAC +* + CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, + $ WORK( IVT ), M, DUM, IDUM, WORK( NWORK ), + $ IWORK, INFO ) +* +* Overwrite U by left singular vectors of L and WORK(IVT) +* by right singular vectors of L +* Workspace: need M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M [work] +* Workspace: prefer M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M*NB [work] +* + CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) + CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL, + $ WORK( ITAUP ), WORK( IVT ), M, + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) +* +* Multiply right singular vectors of L in WORK(IVT) by Q +* in A, storing result in WORK(IL) and copying to A +* Workspace: need M*M [VT] + M*M [L] +* Workspace: prefer M*M [VT] + M*N [L] +* At this point, L is resized as M by chunk. +* + DO 30 I = 1, N, CHUNK + BLK = MIN( N - I + 1, CHUNK ) + CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), M, + $ A( 1, I ), LDA, ZERO, WORK( IL ), LDWRKL ) + CALL DLACPY( 'F', M, BLK, WORK( IL ), LDWRKL, + $ A( 1, I ), LDA ) + 30 CONTINUE +* + ELSE IF( WNTQS ) THEN +* +* Path 3t (N >> M, JOBZ='S') +* M right singular vectors to be computed in VT and +* M left singular vectors to be computed in U +* + IL = 1 +* +* WORK(IL) is M by M +* + LDWRKL = M + ITAU = IL + LDWRKL*M + NWORK = ITAU + M +* +* Compute A=L*Q +* Workspace: need M*M [L] + M [tau] + M [work] +* Workspace: prefer M*M [L] + M [tau] + M*NB [work] +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) +* +* Copy L to WORK(IL), zeroing out above it +* + CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL ) + CALL DLASET( 'U', M - 1, M - 1, ZERO, ZERO, + $ WORK( IL + LDWRKL ), LDWRKL ) +* +* Generate Q in A +* Workspace: need M*M [L] + M [tau] + M [work] +* Workspace: prefer M*M [L] + M [tau] + M*NB [work] +* + CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) + IE = ITAU + ITAUQ = IE + M + ITAUP = ITAUQ + M + NWORK = ITAUP + M +* +* Bidiagonalize L in WORK(IU). +* Workspace: need M*M [L] + 3*M [e, tauq, taup] + M [work] +* Workspace: prefer M*M [L] + 3*M [e, tauq, taup] + 2*M*NB [work] +* + CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in U and computing right singular +* vectors of bidiagonal matrix in VT +* Workspace: need M*M [L] + 3*M [e, tauq, taup] + BDSPAC +* + CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, VT, + $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, + $ INFO ) +* +* Overwrite U by left singular vectors of L and VT +* by right singular vectors of L +* Workspace: need M*M [L] + 3*M [e, tauq, taup] + M [work] +* Workspace: prefer M*M [L] + 3*M [e, tauq, taup] + M*NB [work] +* + CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) + CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) +* +* Multiply right singular vectors of L in WORK(IL) by +* Q in A, storing result in VT +* Workspace: need M*M [L] +* + CALL DLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL ) + CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IL ), LDWRKL, + $ A, LDA, ZERO, VT, LDVT ) +* + ELSE IF( WNTQA ) THEN +* +* Path 4t (N >> M, JOBZ='A') +* N right singular vectors to be computed in VT and +* M left singular vectors to be computed in U +* + IVT = 1 +* +* WORK(IVT) is M by M +* + LDWKVT = M + ITAU = IVT + LDWKVT*M + NWORK = ITAU + M +* +* Compute A=L*Q, copying result to VT +* Workspace: need M*M [VT] + M [tau] + M [work] +* Workspace: prefer M*M [VT] + M [tau] + M*NB [work] +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) + CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* Workspace: need M*M [VT] + M [tau] + N [work] +* Workspace: prefer M*M [VT] + M [tau] + N*NB [work] +* + CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) +* +* Produce L in A, zeroing out other entries +* + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA ) + IE = ITAU + ITAUQ = IE + M + ITAUP = ITAUQ + M + NWORK = ITAUP + M +* +* Bidiagonalize L in A +* Workspace: need M*M [VT] + 3*M [e, tauq, taup] + M [work] +* Workspace: prefer M*M [VT] + 3*M [e, tauq, taup] + 2*M*NB [work] +* + CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, + $ IERR ) +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in U and computing right singular +* vectors of bidiagonal matrix in WORK(IVT) +* Workspace: need M*M [VT] + 3*M [e, tauq, taup] + BDSPAC +* + CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, + $ WORK( IVT ), LDWKVT, DUM, IDUM, + $ WORK( NWORK ), IWORK, INFO ) +* +* Overwrite U by left singular vectors of L and WORK(IVT) +* by right singular vectors of L +* Workspace: need M*M [VT] + 3*M [e, tauq, taup]+ M [work] +* Workspace: prefer M*M [VT] + 3*M [e, tauq, taup]+ M*NB [work] +* + CALL DORMBR( 'Q', 'L', 'N', M, M, M, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) + CALL DORMBR( 'P', 'R', 'T', M, M, M, A, LDA, + $ WORK( ITAUP ), WORK( IVT ), LDWKVT, + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) +* +* Multiply right singular vectors of L in WORK(IVT) by +* Q in VT, storing result in A +* Workspace: need M*M [VT] +* + CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IVT ), LDWKVT, + $ VT, LDVT, ZERO, A, LDA ) +* +* Copy right singular vectors of A from A to VT +* + CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT ) +* + END IF +* + ELSE +* +* N .LT. MNTHR +* +* Path 5t (N > M, but not much larger) +* Reduce to bidiagonal form without LQ decomposition +* + IE = 1 + ITAUQ = IE + M + ITAUP = ITAUQ + M + NWORK = ITAUP + M +* +* Bidiagonalize A +* Workspace: need 3*M [e, tauq, taup] + N [work] +* Workspace: prefer 3*M [e, tauq, taup] + (M+N)*NB [work] +* + CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, + $ IERR ) + IF( WNTQN ) THEN +* +* Path 5tn (N > M, JOBZ='N') +* Perform bidiagonal SVD, only computing singular values +* Workspace: need 3*M [e, tauq, taup] + BDSPAC +* + CALL DBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1, + $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) + ELSE IF( WNTQO ) THEN +* Path 5to (N > M, JOBZ='O') + LDWKVT = M + IVT = NWORK + IF( LWORK .GE. M*N + 3*M + BDSPAC ) THEN +* +* WORK( IVT ) is M by N +* + CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IVT ), + $ LDWKVT ) + NWORK = IVT + LDWKVT*N +* IL is unused; silence compile warnings + IL = -1 + ELSE +* +* WORK( IVT ) is M by M +* + NWORK = IVT + LDWKVT*M + IL = NWORK +* +* WORK(IL) is M by CHUNK +* + CHUNK = ( LWORK - M*M - 3*M ) / M + END IF +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in U and computing right singular +* vectors of bidiagonal matrix in WORK(IVT) +* Workspace: need 3*M [e, tauq, taup] + M*M [VT] + BDSPAC +* + CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, + $ WORK( IVT ), LDWKVT, DUM, IDUM, + $ WORK( NWORK ), IWORK, INFO ) +* +* Overwrite U by left singular vectors of A +* Workspace: need 3*M [e, tauq, taup] + M*M [VT] + M [work] +* Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*NB [work] +* + CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) +* + IF( LWORK .GE. M*N + 3*M + BDSPAC ) THEN +* +* Path 5to-fast +* Overwrite WORK(IVT) by left singular vectors of A +* Workspace: need 3*M [e, tauq, taup] + M*N [VT] + M [work] +* Workspace: prefer 3*M [e, tauq, taup] + M*N [VT] + M*NB [work] +* + CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA, + $ WORK( ITAUP ), WORK( IVT ), LDWKVT, + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) +* +* Copy right singular vectors of A from WORK(IVT) to A +* + CALL DLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA ) + ELSE +* +* Path 5to-slow +* Generate P**T in A +* Workspace: need 3*M [e, tauq, taup] + M*M [VT] + M [work] +* Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*NB [work] +* + CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) +* +* Multiply Q in A by right singular vectors of +* bidiagonal matrix in WORK(IVT), storing result in +* WORK(IL) and copying to A +* Workspace: need 3*M [e, tauq, taup] + M*M [VT] + M*NB [L] +* Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*N [L] +* + DO 40 I = 1, N, CHUNK + BLK = MIN( N - I + 1, CHUNK ) + CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), + $ LDWKVT, A( 1, I ), LDA, ZERO, + $ WORK( IL ), M ) + CALL DLACPY( 'F', M, BLK, WORK( IL ), M, A( 1, I ), + $ LDA ) + 40 CONTINUE + END IF + ELSE IF( WNTQS ) THEN +* +* Path 5ts (N > M, JOBZ='S') +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in U and computing right singular +* vectors of bidiagonal matrix in VT +* Workspace: need 3*M [e, tauq, taup] + BDSPAC +* + CALL DLASET( 'F', M, N, ZERO, ZERO, VT, LDVT ) + CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT, + $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, + $ INFO ) +* +* Overwrite U by left singular vectors of A and VT +* by right singular vectors of A +* Workspace: need 3*M [e, tauq, taup] + M [work] +* Workspace: prefer 3*M [e, tauq, taup] + M*NB [work] +* + CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) + CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) + ELSE IF( WNTQA ) THEN +* +* Path 5ta (N > M, JOBZ='A') +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in U and computing right singular +* vectors of bidiagonal matrix in VT +* Workspace: need 3*M [e, tauq, taup] + BDSPAC +* + CALL DLASET( 'F', N, N, ZERO, ZERO, VT, LDVT ) + CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT, + $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, + $ INFO ) +* +* Set the right corner of VT to identity matrix +* + IF( N.GT.M ) THEN + CALL DLASET( 'F', N-M, N-M, ZERO, ONE, VT(M+1,M+1), + $ LDVT ) + END IF +* +* Overwrite U by left singular vectors of A and VT +* by right singular vectors of A +* Workspace: need 3*M [e, tauq, taup] + N [work] +* Workspace: prefer 3*M [e, tauq, taup] + N*NB [work] +* + CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) + CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK - NWORK + 1, IERR ) + 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( ANRM.LT.SMLNUM ) + $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, + $ IERR ) + END IF +* +* Return optimal workspace in WORK(1) +* + WORK( 1 ) = MAXWRK +* + RETURN +* +* End of DGESDD +* + END diff --git a/math/lapack/src/main/fortran/dgesv.f b/math/lapack/src/main/fortran/dgesv.f new file mode 100644 index 0000000000..23999e167f --- /dev/null +++ b/math/lapack/src/main/fortran/dgesv.f @@ -0,0 +1,179 @@ +*> \brief DGESV computes the solution to system of linear equations A * X = B for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGESV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices that define the permutation matrix P; +*> row i of the matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEsolve +* +* ===================================================================== + SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dgesvdx.f b/math/lapack/src/main/fortran/dgesvdx.f new file mode 100644 index 0000000000..7da3d099c3 --- /dev/null +++ b/math/lapack/src/main/fortran/dgesvdx.f @@ -0,0 +1,834 @@ +*> \brief DGESVDX computes the singular value decomposition (SVD) for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGESVDX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, +* $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, +* $ LWORK, IWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER JOBU, JOBVT, RANGE +* INTEGER IL, INFO, IU, LDA, LDU, LDVT, LWORK, M, N, NS +* DOUBLE PRECISION VL, VU +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), +* $ VT( LDVT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGESVDX 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. +*> +*> DGESVDX uses an eigenvalue problem for obtaining the SVD, which +*> allows for the computation of a subset of singular values and +*> vectors. See DBDSVDX for details. +*> +*> Note that the routine returns V**T, not V. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBU +*> \verbatim +*> JOBU is CHARACTER*1 +*> Specifies options for computing all or part of the matrix U: +*> = 'V': the first min(m,n) columns of U (the left singular +*> vectors) or as specified by RANGE are returned in +*> the array U; +*> = 'N': no columns of U (no left singular vectors) are +*> computed. +*> \endverbatim +*> +*> \param[in] JOBVT +*> \verbatim +*> JOBVT is CHARACTER*1 +*> Specifies options for computing all or part of the matrix +*> V**T: +*> = 'V': the first min(m,n) rows of V**T (the right singular +*> vectors) or as specified by RANGE are returned in +*> the array VT; +*> = 'N': no rows of V**T (no right singular vectors) are +*> computed. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all singular values will be found. +*> = 'V': all singular values in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th singular values will be found. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the input matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the input matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the contents of A are destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for singular values. VU > VL. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for singular values. VU > VL. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest singular value to be returned. +*> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest singular value to be returned. +*> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[out] NS +*> \verbatim +*> NS is INTEGER +*> The total number of singular values found, +*> 0 <= NS <= min(M,N). +*> If RANGE = 'A', NS = min(M,N); if RANGE = 'I', NS = IU-IL+1. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (min(M,N)) +*> The singular values of A, sorted so that S(i) >= S(i+1). +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension (LDU,UCOL) +*> If JOBU = 'V', U contains columns of U (the left singular +*> vectors, stored columnwise) as specified by RANGE; if +*> JOBU = 'N', U is not referenced. +*> Note: The user must ensure that UCOL >= NS; if RANGE = 'V', +*> the exact value of NS is not known in advance and an upper +*> bound must be used. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of the array U. LDU >= 1; if +*> JOBU = 'V', LDU >= M. +*> \endverbatim +*> +*> \param[out] VT +*> \verbatim +*> VT is DOUBLE PRECISION array, dimension (LDVT,N) +*> If JOBVT = 'V', VT contains the rows of V**T (the right singular +*> vectors, stored rowwise) as specified by RANGE; if JOBVT = 'N', +*> VT is not referenced. +*> Note: The user must ensure that LDVT >= NS; if RANGE = 'V', +*> the exact value of NS is not known in advance and an upper +*> bound must be used. +*> \endverbatim +*> +*> \param[in] LDVT +*> \verbatim +*> LDVT is INTEGER +*> The leading dimension of the array VT. LDVT >= 1; if +*> JOBVT = 'V', LDVT >= NS (see above). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK; +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> LWORK >= MAX(1,MIN(M,N)*(MIN(M,N)+4)) for the paths (see +*> comments inside the code): +*> - PATH 1 (M much larger than N) +*> - PATH 1t (N much larger than M) +*> LWORK >= MAX(1,MIN(M,N)*2+MAX(M,N)) for the other paths. +*> 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. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (12*MIN(M,N)) +*> If INFO = 0, the first NS elements of IWORK are zero. If INFO > 0, +*> then IWORK contains the indices of the eigenvectors that failed +*> to converge in DBDSVDX/DSTEVX. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, then i eigenvectors failed to converge +*> in DBDSVDX/DSTEVX. +*> if INFO = N*2 + 1, an internal error occurred in +*> DBDSVDX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleGEsing +* +* ===================================================================== + SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, + $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, + $ LWORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBU, JOBVT, RANGE + INTEGER IL, INFO, IU, LDA, LDU, LDVT, LWORK, M, N, NS + DOUBLE PRECISION VL, VU +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), + $ VT( LDVT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + CHARACTER JOBZ, RNGTGK + LOGICAL ALLS, INDS, LQUERY, VALS, WANTU, WANTVT + INTEGER I, ID, IE, IERR, ILQF, ILTGK, IQRF, ISCL, + $ ITAU, ITAUP, ITAUQ, ITEMP, ITGKZ, IUTGK, + $ J, MAXWRK, MINMN, MINWRK, MNTHR + DOUBLE PRECISION ABSTOL, ANRM, BIGNUM, EPS, SMLNUM +* .. +* .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DBDSVDX, DGEBRD, DGELQF, DGEQRF, DLACPY, + $ DLASCL, DLASET, DORMBR, DORMLQ, DORMQR, + $ 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. +* + NS = 0 + INFO = 0 + ABSTOL = 2*DLAMCH('S') + LQUERY = ( LWORK.EQ.-1 ) + MINMN = MIN( M, N ) + + WANTU = LSAME( JOBU, 'V' ) + WANTVT = LSAME( JOBVT, 'V' ) + IF( WANTU .OR. WANTVT ) THEN + JOBZ = 'V' + ELSE + JOBZ = 'N' + END IF + ALLS = LSAME( RANGE, 'A' ) + VALS = LSAME( RANGE, 'V' ) + INDS = LSAME( RANGE, 'I' ) +* + INFO = 0 + IF( .NOT.LSAME( JOBU, 'V' ) .AND. + $ .NOT.LSAME( JOBU, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( JOBVT, 'V' ) .AND. + $ .NOT.LSAME( JOBVT, 'N' ) ) THEN + INFO = -2 + ELSE IF( .NOT.( ALLS .OR. VALS .OR. INDS ) ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.GT.LDA ) THEN + INFO = -7 + ELSE IF( MINMN.GT.0 ) THEN + IF( VALS ) THEN + IF( VL.LT.ZERO ) THEN + INFO = -8 + ELSE IF( VU.LE.VL ) THEN + INFO = -9 + END IF + ELSE IF( INDS ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, MINMN ) ) THEN + INFO = -10 + ELSE IF( IU.LT.MIN( MINMN, IL ) .OR. IU.GT.MINMN ) THEN + INFO = -11 + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( WANTU .AND. LDU.LT.M ) THEN + INFO = -15 + ELSE IF( WANTVT ) THEN + IF( INDS ) THEN + IF( LDVT.LT.IU-IL+1 ) THEN + INFO = -17 + END IF + ELSE IF( LDVT.LT.MINMN ) THEN + INFO = -17 + END IF + END IF + END IF + 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 + IF( M.GE.N ) THEN + MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) + IF( M.GE.MNTHR ) THEN +* +* Path 1 (M much larger than N) +* + MAXWRK = N + + $ N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + MAXWRK = MAX( MAXWRK, N*(N+5) + 2*N* + $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) + IF (WANTU) THEN + MAXWRK = MAX(MAXWRK,N*(N*3+6)+N* + $ ILAENV( 1, 'DORMQR', ' ', N, N, -1, -1 ) ) + END IF + IF (WANTVT) THEN + MAXWRK = MAX(MAXWRK,N*(N*3+6)+N* + $ ILAENV( 1, 'DORMLQ', ' ', N, N, -1, -1 ) ) + END IF + MINWRK = N*(N*3+20) + ELSE +* +* Path 2 (M at least N, but not much larger) +* + MAXWRK = 4*N + ( M+N )* + $ ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) + IF (WANTU) THEN + MAXWRK = MAX(MAXWRK,N*(N*2+5)+N* + $ ILAENV( 1, 'DORMQR', ' ', N, N, -1, -1 ) ) + END IF + IF (WANTVT) THEN + MAXWRK = MAX(MAXWRK,N*(N*2+5)+N* + $ ILAENV( 1, 'DORMLQ', ' ', N, N, -1, -1 ) ) + END IF + MINWRK = MAX(N*(N*2+19),4*N+M) + END IF + ELSE + MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) + IF( N.GE.MNTHR ) THEN +* +* Path 1t (N much larger than M) +* + MAXWRK = M + + $ M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + MAXWRK = MAX( MAXWRK, M*(M+5) + 2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + IF (WANTU) THEN + MAXWRK = MAX(MAXWRK,M*(M*3+6)+M* + $ ILAENV( 1, 'DORMQR', ' ', M, M, -1, -1 ) ) + END IF + IF (WANTVT) THEN + MAXWRK = MAX(MAXWRK,M*(M*3+6)+M* + $ ILAENV( 1, 'DORMLQ', ' ', M, M, -1, -1 ) ) + END IF + MINWRK = M*(M*3+20) + ELSE +* +* Path 2t (N at least M, but not much larger) +* + MAXWRK = 4*M + ( M+N )* + $ ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) + IF (WANTU) THEN + MAXWRK = MAX(MAXWRK,M*(M*2+5)+M* + $ ILAENV( 1, 'DORMQR', ' ', M, M, -1, -1 ) ) + END IF + IF (WANTVT) THEN + MAXWRK = MAX(MAXWRK,M*(M*2+5)+M* + $ ILAENV( 1, 'DORMLQ', ' ', M, M, -1, -1 ) ) + END IF + MINWRK = MAX(M*(M*2+19),4*M+N) + END IF + END IF + END IF + MAXWRK = MAX( MAXWRK, MINWRK ) + WORK( 1 ) = DBLE( MAXWRK ) +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -19 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGESVDX', -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 +* +* Set singular values indices accord to RANGE. +* + IF( ALLS ) THEN + RNGTGK = 'I' + ILTGK = 1 + IUTGK = MIN( M, N ) + ELSE IF( INDS ) THEN + RNGTGK = 'I' + ILTGK = IL + IUTGK = IU + ELSE + RNGTGK = 'V' + ILTGK = 0 + IUTGK = 0 + 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, INFO ) + ELSE IF( ANRM.GT.BIGNUM ) THEN + ISCL = 1 + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) + 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 A using the QR +* decomposition. +* + IF( M.GE.MNTHR ) THEN +* +* Path 1 (M much larger than N): +* A = Q * R = Q * ( QB * B * PB**T ) +* = Q * ( QB * ( UB * S * VB**T ) * PB**T ) +* U = Q * QB * UB; V**T = VB**T * PB**T +* +* Compute A=Q*R +* (Workspace: need 2*N, prefer N+N*NB) +* + ITAU = 1 + ITEMP = ITAU + N + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( ITEMP ), + $ LWORK-ITEMP+1, INFO ) +* +* Copy R into WORK and bidiagonalize it: +* (Workspace: need N*N+5*N, prefer N*N+4*N+2*N*NB) +* + IQRF = ITEMP + ID = IQRF + N*N + IE = ID + N + ITAUQ = IE + N + ITAUP = ITAUQ + N + ITEMP = ITAUP + N + CALL DLACPY( 'U', N, N, A, LDA, WORK( IQRF ), N ) + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IQRF+1 ), N ) + CALL DGEBRD( N, N, WORK( IQRF ), N, WORK( ID ), WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), + $ LWORK-ITEMP+1, INFO ) +* +* Solve eigenvalue problem TGK*Z=Z*S. +* (Workspace: need 14*N + 2*N*(N+1)) +* + ITGKZ = ITEMP + ITEMP = ITGKZ + N*(N*2+1) + CALL DBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), WORK( IE ), + $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), + $ N*2, WORK( ITEMP ), IWORK, INFO) +* +* If needed, compute left singular vectors. +* + IF( WANTU ) THEN + J = ITGKZ + DO I = 1, NS + CALL DCOPY( N, WORK( J ), 1, U( 1,I ), 1 ) + J = J + N*2 + END DO + CALL DLASET( 'A', M-N, NS, ZERO, ZERO, U( N+1,1 ), LDU ) +* +* Call DORMBR to compute QB*UB. +* (Workspace in WORK( ITEMP ): need N, prefer N*NB) +* + CALL DORMBR( 'Q', 'L', 'N', N, NS, N, WORK( IQRF ), N, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), + $ LWORK-ITEMP+1, INFO ) +* +* Call DORMQR to compute Q*(QB*UB). +* (Workspace in WORK( ITEMP ): need N, prefer N*NB) +* + CALL DORMQR( 'L', 'N', M, NS, N, A, LDA, + $ WORK( ITAU ), U, LDU, WORK( ITEMP ), + $ LWORK-ITEMP+1, INFO ) + END IF +* +* If needed, compute right singular vectors. +* + IF( WANTVT) THEN + J = ITGKZ + N + DO I = 1, NS + CALL DCOPY( N, WORK( J ), 1, VT( I,1 ), LDVT ) + J = J + N*2 + END DO +* +* Call DORMBR to compute VB**T * PB**T +* (Workspace in WORK( ITEMP ): need N, prefer N*NB) +* + CALL DORMBR( 'P', 'R', 'T', NS, N, N, WORK( IQRF ), N, + $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), + $ LWORK-ITEMP+1, INFO ) + END IF + ELSE +* +* Path 2 (M at least N, but not much larger) +* Reduce A to bidiagonal form without QR decomposition +* A = QB * B * PB**T = QB * ( UB * S * VB**T ) * PB**T +* U = QB * UB; V**T = VB**T * PB**T +* +* Bidiagonalize A +* (Workspace: need 4*N+M, prefer 4*N+(M+N)*NB) +* + ID = 1 + IE = ID + N + ITAUQ = IE + N + ITAUP = ITAUQ + N + ITEMP = ITAUP + N + CALL DGEBRD( M, N, A, LDA, WORK( ID ), WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), + $ LWORK-ITEMP+1, INFO ) +* +* Solve eigenvalue problem TGK*Z=Z*S. +* (Workspace: need 14*N + 2*N*(N+1)) +* + ITGKZ = ITEMP + ITEMP = ITGKZ + N*(N*2+1) + CALL DBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), WORK( IE ), + $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), + $ N*2, WORK( ITEMP ), IWORK, INFO) +* +* If needed, compute left singular vectors. +* + IF( WANTU ) THEN + J = ITGKZ + DO I = 1, NS + CALL DCOPY( N, WORK( J ), 1, U( 1,I ), 1 ) + J = J + N*2 + END DO + CALL DLASET( 'A', M-N, NS, ZERO, ZERO, U( N+1,1 ), LDU ) +* +* Call DORMBR to compute QB*UB. +* (Workspace in WORK( ITEMP ): need N, prefer N*NB) +* + CALL DORMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), + $ LWORK-ITEMP+1, IERR ) + END IF +* +* If needed, compute right singular vectors. +* + IF( WANTVT) THEN + J = ITGKZ + N + DO I = 1, NS + CALL DCOPY( N, WORK( J ), 1, VT( I,1 ), LDVT ) + J = J + N*2 + END DO +* +* Call DORMBR to compute VB**T * PB**T +* (Workspace in WORK( ITEMP ): need N, prefer N*NB) +* + CALL DORMBR( 'P', 'R', 'T', NS, N, N, A, LDA, + $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), + $ LWORK-ITEMP+1, IERR ) + END IF + END IF + ELSE +* +* A has more columns than rows. If A has sufficiently more +* columns than rows, first reduce A using the LQ decomposition. +* + IF( N.GE.MNTHR ) THEN +* +* Path 1t (N much larger than M): +* A = L * Q = ( QB * B * PB**T ) * Q +* = ( QB * ( UB * S * VB**T ) * PB**T ) * Q +* U = QB * UB ; V**T = VB**T * PB**T * Q +* +* Compute A=L*Q +* (Workspace: need 2*M, prefer M+M*NB) +* + ITAU = 1 + ITEMP = ITAU + M + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( ITEMP ), + $ LWORK-ITEMP+1, INFO ) + +* Copy L into WORK and bidiagonalize it: +* (Workspace in WORK( ITEMP ): need M*M+5*N, prefer M*M+4*M+2*M*NB) +* + ILQF = ITEMP + ID = ILQF + M*M + IE = ID + M + ITAUQ = IE + M + ITAUP = ITAUQ + M + ITEMP = ITAUP + M + CALL DLACPY( 'L', M, M, A, LDA, WORK( ILQF ), M ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( ILQF+M ), M ) + CALL DGEBRD( M, M, WORK( ILQF ), M, WORK( ID ), WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), + $ LWORK-ITEMP+1, INFO ) +* +* Solve eigenvalue problem TGK*Z=Z*S. +* (Workspace: need 2*M*M+14*M) +* + ITGKZ = ITEMP + ITEMP = ITGKZ + M*(M*2+1) + CALL DBDSVDX( 'U', JOBZ, RNGTGK, M, WORK( ID ), WORK( IE ), + $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), + $ M*2, WORK( ITEMP ), IWORK, INFO) +* +* If needed, compute left singular vectors. +* + IF( WANTU ) THEN + J = ITGKZ + DO I = 1, NS + CALL DCOPY( M, WORK( J ), 1, U( 1,I ), 1 ) + J = J + M*2 + END DO +* +* Call DORMBR to compute QB*UB. +* (Workspace in WORK( ITEMP ): need M, prefer M*NB) +* + CALL DORMBR( 'Q', 'L', 'N', M, NS, M, WORK( ILQF ), M, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), + $ LWORK-ITEMP+1, INFO ) + END IF +* +* If needed, compute right singular vectors. +* + IF( WANTVT) THEN + J = ITGKZ + M + DO I = 1, NS + CALL DCOPY( M, WORK( J ), 1, VT( I,1 ), LDVT ) + J = J + M*2 + END DO + CALL DLASET( 'A', NS, N-M, ZERO, ZERO, VT( 1,M+1 ), LDVT) +* +* Call DORMBR to compute (VB**T)*(PB**T) +* (Workspace in WORK( ITEMP ): need M, prefer M*NB) +* + CALL DORMBR( 'P', 'R', 'T', NS, M, M, WORK( ILQF ), M, + $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), + $ LWORK-ITEMP+1, INFO ) +* +* Call DORMLQ to compute ((VB**T)*(PB**T))*Q. +* (Workspace in WORK( ITEMP ): need M, prefer M*NB) +* + CALL DORMLQ( 'R', 'N', NS, N, M, A, LDA, + $ WORK( ITAU ), VT, LDVT, WORK( ITEMP ), + $ LWORK-ITEMP+1, INFO ) + END IF + ELSE +* +* Path 2t (N greater than M, but not much larger) +* Reduce to bidiagonal form without LQ decomposition +* A = QB * B * PB**T = QB * ( UB * S * VB**T ) * PB**T +* U = QB * UB; V**T = VB**T * PB**T +* +* Bidiagonalize A +* (Workspace: need 4*M+N, prefer 4*M+(M+N)*NB) +* + ID = 1 + IE = ID + M + ITAUQ = IE + M + ITAUP = ITAUQ + M + ITEMP = ITAUP + M + CALL DGEBRD( M, N, A, LDA, WORK( ID ), WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), + $ LWORK-ITEMP+1, INFO ) +* +* Solve eigenvalue problem TGK*Z=Z*S. +* (Workspace: need 2*M*M+14*M) +* + ITGKZ = ITEMP + ITEMP = ITGKZ + M*(M*2+1) + CALL DBDSVDX( 'L', JOBZ, RNGTGK, M, WORK( ID ), WORK( IE ), + $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), + $ M*2, WORK( ITEMP ), IWORK, INFO) +* +* If needed, compute left singular vectors. +* + IF( WANTU ) THEN + J = ITGKZ + DO I = 1, NS + CALL DCOPY( M, WORK( J ), 1, U( 1,I ), 1 ) + J = J + M*2 + END DO +* +* Call DORMBR to compute QB*UB. +* (Workspace in WORK( ITEMP ): need M, prefer M*NB) +* + CALL DORMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), + $ LWORK-ITEMP+1, INFO ) + END IF +* +* If needed, compute right singular vectors. +* + IF( WANTVT) THEN + J = ITGKZ + M + DO I = 1, NS + CALL DCOPY( M, WORK( J ), 1, VT( I,1 ), LDVT ) + J = J + M*2 + END DO + CALL DLASET( 'A', NS, N-M, ZERO, ZERO, VT( 1,M+1 ), LDVT) +* +* Call DORMBR to compute VB**T * PB**T +* (Workspace in WORK( ITEMP ): need M, prefer M*NB) +* + CALL DORMBR( 'P', 'R', 'T', NS, N, M, A, LDA, + $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), + $ LWORK-ITEMP+1, 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, INFO ) + IF( ANRM.LT.SMLNUM ) + $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, + $ S, MINMN, INFO ) + END IF +* +* Return optimal workspace in WORK(1) +* + WORK( 1 ) = DBLE( MAXWRK ) +* + RETURN +* +* End of DGESVDX +* + END diff --git a/math/lapack/src/main/fortran/dgesvj.f b/math/lapack/src/main/fortran/dgesvj.f new file mode 100644 index 0000000000..2b2599420c --- /dev/null +++ b/math/lapack/src/main/fortran/dgesvj.f @@ -0,0 +1,1615 @@ +*> \brief \b DGESVJ +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGESVJ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, +* LDV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDV, LWORK, M, MV, N +* CHARACTER*1 JOBA, JOBU, JOBV +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), SVA( N ), V( LDV, * ), +* $ WORK( LWORK ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGESVJ computes the singular value decomposition (SVD) of a real +*> M-by-N matrix A, where M >= N. The SVD of A is written as +*> [++] [xx] [x0] [xx] +*> A = U * SIGMA * V^t, [++] = [xx] * [ox] * [xx] +*> [++] [xx] +*> where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal +*> matrix, and V is an N-by-N orthogonal matrix. The diagonal elements +*> of SIGMA are the singular values of A. The columns of U and V are the +*> left and the right singular vectors of A, respectively. +*> DGESVJ can sometimes compute tiny singular values and their singular vectors much +*> more accurately than other SVD routines, see below under Further Details. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBA +*> \verbatim +*> JOBA is CHARACTER* 1 +*> Specifies the structure of A. +*> = 'L': The input matrix A is lower triangular; +*> = 'U': The input matrix A is upper triangular; +*> = 'G': The input matrix A is general M-by-N matrix, M >= N. +*> \endverbatim +*> +*> \param[in] JOBU +*> \verbatim +*> JOBU is CHARACTER*1 +*> Specifies whether to compute the left singular vectors +*> (columns of U): +*> = 'U': The left singular vectors corresponding to the nonzero +*> singular values are computed and returned in the leading +*> columns of A. See more details in the description of A. +*> The default numerical orthogonality threshold is set to +*> approximately TOL=CTOL*EPS, CTOL=DSQRT(M), EPS=DLAMCH('E'). +*> = 'C': Analogous to JOBU='U', except that user can control the +*> level of numerical orthogonality of the computed left +*> singular vectors. TOL can be set to TOL = CTOL*EPS, where +*> CTOL is given on input in the array WORK. +*> No CTOL smaller than ONE is allowed. CTOL greater +*> than 1 / EPS is meaningless. The option 'C' +*> can be used if M*EPS is satisfactory orthogonality +*> of the computed left singular vectors, so CTOL=M could +*> save few sweeps of Jacobi rotations. +*> See the descriptions of A and WORK(1). +*> = 'N': The matrix U is not computed. However, see the +*> description of A. +*> \endverbatim +*> +*> \param[in] JOBV +*> \verbatim +*> JOBV is CHARACTER*1 +*> Specifies whether to compute the right singular vectors, that +*> is, the matrix V: +*> = 'V' : the matrix V is computed and returned in the array V +*> = 'A' : the Jacobi rotations are applied to the MV-by-N +*> array V. In other words, the right singular vector +*> matrix V is not computed explicitly, instead it is +*> applied to an MV-by-N matrix initially stored in the +*> first MV rows of V. +*> = 'N' : the matrix V is not computed and the array V is not +*> referenced +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the input matrix A. 1/DLAMCH('E') > M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the input matrix A. +*> M >= N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit : +*> If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C' : +*> If INFO .EQ. 0 : +*> RANKA orthonormal columns of U are returned in the +*> leading RANKA columns of the array A. Here RANKA <= N +*> is the number of computed singular values of A that are +*> above the underflow threshold DLAMCH('S'). The singular +*> vectors corresponding to underflowed or zero singular +*> values are not computed. The value of RANKA is returned +*> in the array WORK as RANKA=NINT(WORK(2)). Also see the +*> descriptions of SVA and WORK. The computed columns of U +*> are mutually numerically orthogonal up to approximately +*> TOL=DSQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'), +*> see the description of JOBU. +*> If INFO .GT. 0 : +*> the procedure DGESVJ did not converge in the given number +*> of iterations (sweeps). In that case, the computed +*> columns of U may not be orthogonal up to TOL. The output +*> U (stored in A), SIGMA (given by the computed singular +*> values in SVA(1:N)) and V is still a decomposition of the +*> input matrix A in the sense that the residual +*> ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small. +*> +*> If JOBU .EQ. 'N' : +*> If INFO .EQ. 0 : +*> Note that the left singular vectors are 'for free' in the +*> one-sided Jacobi SVD algorithm. However, if only the +*> singular values are needed, the level of numerical +*> orthogonality of U is not an issue and iterations are +*> stopped when the columns of the iterated matrix are +*> numerically orthogonal up to approximately M*EPS. Thus, +*> on exit, A contains the columns of U scaled with the +*> corresponding singular values. +*> If INFO .GT. 0 : +*> the procedure DGESVJ did not converge in the given number +*> of iterations (sweeps). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] SVA +*> \verbatim +*> SVA is DOUBLE PRECISION array, dimension (N) +*> On exit : +*> If INFO .EQ. 0 : +*> depending on the value SCALE = WORK(1), we have: +*> If SCALE .EQ. ONE : +*> SVA(1:N) contains the computed singular values of A. +*> During the computation SVA contains the Euclidean column +*> norms of the iterated matrices in the array A. +*> If SCALE .NE. ONE : +*> The singular values of A are SCALE*SVA(1:N), and this +*> factored representation is due to the fact that some of the +*> singular values of A might underflow or overflow. +*> If INFO .GT. 0 : +*> the procedure DGESVJ did not converge in the given number of +*> iterations (sweeps) and SCALE*SVA(1:N) may not be accurate. +*> \endverbatim +*> +*> \param[in] MV +*> \verbatim +*> MV is INTEGER +*> If JOBV .EQ. 'A', then the product of Jacobi rotations in DGESVJ +*> is applied to the first MV rows of V. See the description of JOBV. +*> \endverbatim +*> +*> \param[in,out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,N) +*> If JOBV = 'V', then V contains on exit the N-by-N matrix of +*> the right singular vectors; +*> If JOBV = 'A', then V contains the product of the computed right +*> singular vector matrix and the initial matrix in +*> the array V. +*> If JOBV = 'N', then V is not referenced. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V, LDV .GE. 1. +*> If JOBV .EQ. 'V', then LDV .GE. max(1,N). +*> If JOBV .EQ. 'A', then LDV .GE. max(1,MV) . +*> \endverbatim +*> +*> \param[in,out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension MAX(6,M+N). +*> On entry : +*> If JOBU .EQ. 'C' : +*> WORK(1) = CTOL, where CTOL defines the threshold for convergence. +*> The process stops if all columns of A are mutually +*> orthogonal up to CTOL*EPS, EPS=DLAMCH('E'). +*> It is required that CTOL >= ONE, i.e. it is not +*> allowed to force the routine to obtain orthogonality +*> below EPS. +*> On exit : +*> WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N) +*> are the computed singular values of A. +*> (See description of SVA().) +*> WORK(2) = NINT(WORK(2)) is the number of the computed nonzero +*> singular values. +*> WORK(3) = NINT(WORK(3)) is the number of the computed singular +*> values that are larger than the underflow threshold. +*> WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi +*> rotations needed for numerical convergence. +*> WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep. +*> This is useful information in cases when DGESVJ did +*> not converge, as it can be used to estimate whether +*> the output is stil useful and for post festum analysis. +*> WORK(6) = the largest absolute value over all sines of the +*> Jacobi rotation angles in the last sweep. It can be +*> useful for a post festum analysis. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> length of WORK, WORK >= MAX(6,M+N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0 : successful exit. +*> < 0 : if INFO = -i, then the i-th argument had an illegal value +*> > 0 : DGESVJ did not converge in the maximal allowed number (30) +*> of sweeps. The output may still be useful. See the +*> description of WORK. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane +*> rotations. The rotations are implemented as fast scaled rotations of +*> Anda and Park [1]. In the case of underflow of the Jacobi angle, a +*> modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses +*> column interchanges of de Rijk [2]. The relative accuracy of the computed +*> singular values and the accuracy of the computed singular vectors (in +*> angle metric) is as guaranteed by the theory of Demmel and Veselic [3]. +*> The condition number that determines the accuracy in the full rank case +*> is essentially min_{D=diag} kappa(A*D), where kappa(.) is the +*> spectral condition number. The best performance of this Jacobi SVD +*> procedure is achieved if used in an accelerated version of Drmac and +*> Veselic [5,6], and it is the kernel routine in the SIGMA library [7]. +*> Some tunning parameters (marked with [TP]) are available for the +*> implementer. +*> The computational range for the nonzero singular values is the machine +*> number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even +*> denormalized singular values can be computed with the corresponding +*> gradual loss of accurate digits. +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> ============ +*> +*> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +*> \endverbatim +* +*> \par References: +* ================ +*> +*> \verbatim +*> +*> [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling. +*> SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174. +*> [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the +*> singular value decomposition on a vector computer. +*> SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371. +*> [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR. +*> [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular +*> value computation in floating point arithmetic. +*> SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222. +*> [5] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I. +*> SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342. +*> LAPACK Working note 169. +*> [6] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II. +*> SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362. +*> LAPACK Working note 170. +*> [7] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, +*> QSVD, (H,K)-SVD computations. +*> Department of Mathematics, University of Zagreb, 2008. +*> \endverbatim +* +*> \par Bugs, examples and comments: +* ================================= +*> +*> \verbatim +*> =========================== +*> Please report all bugs and send interesting test examples and comments to +*> drmac@math.hr. Thank you. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, + $ LDV, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDV, LWORK, M, MV, N + CHARACTER*1 JOBA, JOBU, JOBV +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), SVA( N ), V( LDV, * ), + $ WORK( LWORK ) +* .. +* +* ===================================================================== +* +* .. Local Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0) + INTEGER NSWEEP + PARAMETER ( NSWEEP = 30 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG, + $ BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ, + $ MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL, + $ SKL, SFMIN, SMALL, SN, T, TEMP1, THETA, + $ THSIGN, TOL + INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1, + $ ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34, + $ N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP, + $ SWBAND + LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK, + $ RSVEC, UCTOL, UPPER +* .. +* .. Local Arrays .. + DOUBLE PRECISION FASTR( 5 ) +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS, MAX, MIN, DBLE, DSIGN, DSQRT +* .. +* .. External Functions .. +* .. +* from BLAS + DOUBLE PRECISION DDOT, DNRM2 + EXTERNAL DDOT, DNRM2 + INTEGER IDAMAX + EXTERNAL IDAMAX +* from LAPACK + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. +* .. +* from BLAS + EXTERNAL DAXPY, DCOPY, DROTM, DSCAL, DSWAP +* from LAPACK + EXTERNAL DLASCL, DLASET, DLASSQ, XERBLA +* + EXTERNAL DGSVJ0, DGSVJ1 +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LSVEC = LSAME( JOBU, 'U' ) + UCTOL = LSAME( JOBU, 'C' ) + RSVEC = LSAME( JOBV, 'V' ) + APPLV = LSAME( JOBV, 'A' ) + UPPER = LSAME( JOBA, 'U' ) + LOWER = LSAME( JOBA, 'L' ) +* + IF( .NOT.( UPPER .OR. LOWER .OR. LSAME( JOBA, 'G' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LSVEC .OR. UCTOL .OR. LSAME( JOBU, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( ( N.LT.0 ) .OR. ( N.GT.M ) ) THEN + INFO = -5 + ELSE IF( LDA.LT.M ) THEN + INFO = -7 + ELSE IF( MV.LT.0 ) THEN + INFO = -9 + ELSE IF( ( RSVEC .AND. ( LDV.LT.N ) ) .OR. + $ ( APPLV .AND. ( LDV.LT.MV ) ) ) THEN + INFO = -11 + ELSE IF( UCTOL .AND. ( WORK( 1 ).LE.ONE ) ) THEN + INFO = -12 + ELSE IF( LWORK.LT.MAX( M+N, 6 ) ) THEN + INFO = -13 + ELSE + INFO = 0 + END IF +* +* #:( + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGESVJ', -INFO ) + RETURN + END IF +* +* #:) Quick return for void matrix +* + IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )RETURN +* +* Set numerical parameters +* The stopping criterion for Jacobi rotations is +* +* max_{i<>j}|A(:,i)^T * A(:,j)|/(||A(:,i)||*||A(:,j)||) < CTOL*EPS +* +* where EPS is the round-off and CTOL is defined as follows: +* + IF( UCTOL ) THEN +* ... user controlled + CTOL = WORK( 1 ) + ELSE +* ... default + IF( LSVEC .OR. RSVEC .OR. APPLV ) THEN + CTOL = DSQRT( DBLE( M ) ) + ELSE + CTOL = DBLE( M ) + END IF + END IF +* ... and the machine dependent parameters are +*[!] (Make sure that DLAMCH() works properly on the target machine.) +* + EPSLN = DLAMCH( 'Epsilon' ) + ROOTEPS = DSQRT( EPSLN ) + SFMIN = DLAMCH( 'SafeMinimum' ) + ROOTSFMIN = DSQRT( SFMIN ) + SMALL = SFMIN / EPSLN + BIG = DLAMCH( 'Overflow' ) +* BIG = ONE / SFMIN + ROOTBIG = ONE / ROOTSFMIN + LARGE = BIG / DSQRT( DBLE( M*N ) ) + BIGTHETA = ONE / ROOTEPS +* + TOL = CTOL*EPSLN + ROOTTOL = DSQRT( TOL ) +* + IF( DBLE( M )*EPSLN.GE.ONE ) THEN + INFO = -4 + CALL XERBLA( 'DGESVJ', -INFO ) + RETURN + END IF +* +* Initialize the right singular vector matrix. +* + IF( RSVEC ) THEN + MVL = N + CALL DLASET( 'A', MVL, N, ZERO, ONE, V, LDV ) + ELSE IF( APPLV ) THEN + MVL = MV + END IF + RSVEC = RSVEC .OR. APPLV +* +* Initialize SVA( 1:N ) = ( ||A e_i||_2, i = 1:N ) +*(!) If necessary, scale A to protect the largest singular value +* from overflow. It is possible that saving the largest singular +* value destroys the information about the small ones. +* This initial scaling is almost minimal in the sense that the +* goal is to make sure that no column norm overflows, and that +* DSQRT(N)*max_i SVA(i) does not overflow. If INFinite entries +* in A are detected, the procedure returns with INFO=-6. +* + SKL= ONE / DSQRT( DBLE( M )*DBLE( N ) ) + NOSCALE = .TRUE. + GOSCALE = .TRUE. +* + IF( LOWER ) THEN +* the input matrix is M-by-N lower triangular (trapezoidal) + DO 1874 p = 1, N + AAPP = ZERO + AAQQ = ONE + CALL DLASSQ( M-p+1, A( p, p ), 1, AAPP, AAQQ ) + IF( AAPP.GT.BIG ) THEN + INFO = -6 + CALL XERBLA( 'DGESVJ', -INFO ) + RETURN + END IF + AAQQ = DSQRT( AAQQ ) + IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN + SVA( p ) = AAPP*AAQQ + ELSE + NOSCALE = .FALSE. + SVA( p ) = AAPP*( AAQQ*SKL) + IF( GOSCALE ) THEN + GOSCALE = .FALSE. + DO 1873 q = 1, p - 1 + SVA( q ) = SVA( q )*SKL + 1873 CONTINUE + END IF + END IF + 1874 CONTINUE + ELSE IF( UPPER ) THEN +* the input matrix is M-by-N upper triangular (trapezoidal) + DO 2874 p = 1, N + AAPP = ZERO + AAQQ = ONE + CALL DLASSQ( p, A( 1, p ), 1, AAPP, AAQQ ) + IF( AAPP.GT.BIG ) THEN + INFO = -6 + CALL XERBLA( 'DGESVJ', -INFO ) + RETURN + END IF + AAQQ = DSQRT( AAQQ ) + IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN + SVA( p ) = AAPP*AAQQ + ELSE + NOSCALE = .FALSE. + SVA( p ) = AAPP*( AAQQ*SKL) + IF( GOSCALE ) THEN + GOSCALE = .FALSE. + DO 2873 q = 1, p - 1 + SVA( q ) = SVA( q )*SKL + 2873 CONTINUE + END IF + END IF + 2874 CONTINUE + ELSE +* the input matrix is M-by-N general dense + DO 3874 p = 1, N + AAPP = ZERO + AAQQ = ONE + CALL DLASSQ( M, A( 1, p ), 1, AAPP, AAQQ ) + IF( AAPP.GT.BIG ) THEN + INFO = -6 + CALL XERBLA( 'DGESVJ', -INFO ) + RETURN + END IF + AAQQ = DSQRT( AAQQ ) + IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN + SVA( p ) = AAPP*AAQQ + ELSE + NOSCALE = .FALSE. + SVA( p ) = AAPP*( AAQQ*SKL) + IF( GOSCALE ) THEN + GOSCALE = .FALSE. + DO 3873 q = 1, p - 1 + SVA( q ) = SVA( q )*SKL + 3873 CONTINUE + END IF + END IF + 3874 CONTINUE + END IF +* + IF( NOSCALE )SKL= ONE +* +* Move the smaller part of the spectrum from the underflow threshold +*(!) Start by determining the position of the nonzero entries of the +* array SVA() relative to ( SFMIN, BIG ). +* + AAPP = ZERO + AAQQ = BIG + DO 4781 p = 1, N + IF( SVA( p ).NE.ZERO )AAQQ = MIN( AAQQ, SVA( p ) ) + AAPP = MAX( AAPP, SVA( p ) ) + 4781 CONTINUE +* +* #:) Quick return for zero matrix +* + IF( AAPP.EQ.ZERO ) THEN + IF( LSVEC )CALL DLASET( 'G', M, N, ZERO, ONE, A, LDA ) + WORK( 1 ) = ONE + WORK( 2 ) = ZERO + WORK( 3 ) = ZERO + WORK( 4 ) = ZERO + WORK( 5 ) = ZERO + WORK( 6 ) = ZERO + RETURN + END IF +* +* #:) Quick return for one-column matrix +* + IF( N.EQ.1 ) THEN + IF( LSVEC )CALL DLASCL( 'G', 0, 0, SVA( 1 ), SKL, M, 1, + $ A( 1, 1 ), LDA, IERR ) + WORK( 1 ) = ONE / SKL + IF( SVA( 1 ).GE.SFMIN ) THEN + WORK( 2 ) = ONE + ELSE + WORK( 2 ) = ZERO + END IF + WORK( 3 ) = ZERO + WORK( 4 ) = ZERO + WORK( 5 ) = ZERO + WORK( 6 ) = ZERO + RETURN + END IF +* +* Protect small singular values from underflow, and try to +* avoid underflows/overflows in computing Jacobi rotations. +* + SN = DSQRT( SFMIN / EPSLN ) + TEMP1 = DSQRT( BIG / DBLE( N ) ) + IF( ( AAPP.LE.SN ) .OR. ( AAQQ.GE.TEMP1 ) .OR. + $ ( ( SN.LE.AAQQ ) .AND. ( AAPP.LE.TEMP1 ) ) ) THEN + TEMP1 = MIN( BIG, TEMP1 / AAPP ) +* AAQQ = AAQQ*TEMP1 +* AAPP = AAPP*TEMP1 + ELSE IF( ( AAQQ.LE.SN ) .AND. ( AAPP.LE.TEMP1 ) ) THEN + TEMP1 = MIN( SN / AAQQ, BIG / ( AAPP*DSQRT( DBLE( N ) ) ) ) +* AAQQ = AAQQ*TEMP1 +* AAPP = AAPP*TEMP1 + ELSE IF( ( AAQQ.GE.SN ) .AND. ( AAPP.GE.TEMP1 ) ) THEN + TEMP1 = MAX( SN / AAQQ, TEMP1 / AAPP ) +* AAQQ = AAQQ*TEMP1 +* AAPP = AAPP*TEMP1 + ELSE IF( ( AAQQ.LE.SN ) .AND. ( AAPP.GE.TEMP1 ) ) THEN + TEMP1 = MIN( SN / AAQQ, BIG / ( DSQRT( DBLE( N ) )*AAPP ) ) +* AAQQ = AAQQ*TEMP1 +* AAPP = AAPP*TEMP1 + ELSE + TEMP1 = ONE + END IF +* +* Scale, if necessary +* + IF( TEMP1.NE.ONE ) THEN + CALL DLASCL( 'G', 0, 0, ONE, TEMP1, N, 1, SVA, N, IERR ) + END IF + SKL= TEMP1*SKL + IF( SKL.NE.ONE ) THEN + CALL DLASCL( JOBA, 0, 0, ONE, SKL, M, N, A, LDA, IERR ) + SKL= ONE / SKL + END IF +* +* Row-cyclic Jacobi SVD algorithm with column pivoting +* + EMPTSW = ( N*( N-1 ) ) / 2 + NOTROT = 0 + FASTR( 1 ) = ZERO +* +* A is represented in factored form A = A * diag(WORK), where diag(WORK) +* is initialized to identity. WORK is updated during fast scaled +* rotations. +* + DO 1868 q = 1, N + WORK( q ) = ONE + 1868 CONTINUE +* +* + SWBAND = 3 +*[TP] SWBAND is a tuning parameter [TP]. It is meaningful and effective +* if DGESVJ is used as a computational routine in the preconditioned +* Jacobi SVD algorithm DGESVJ. For sweeps i=1:SWBAND the procedure +* works on pivots inside a band-like region around the diagonal. +* The boundaries are determined dynamically, based on the number of +* pivots above a threshold. +* + KBL = MIN( 8, N ) +*[TP] KBL is a tuning parameter that defines the tile size in the +* tiling of the p-q loops of pivot pairs. In general, an optimal +* value of KBL depends on the matrix dimensions and on the +* parameters of the computer's memory. +* + NBL = N / KBL + IF( ( NBL*KBL ).NE.N )NBL = NBL + 1 +* + BLSKIP = KBL**2 +*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. +* + ROWSKIP = MIN( 5, KBL ) +*[TP] ROWSKIP is a tuning parameter. +* + LKAHEAD = 1 +*[TP] LKAHEAD is a tuning parameter. +* +* Quasi block transformations, using the lower (upper) triangular +* structure of the input matrix. The quasi-block-cycling usually +* invokes cubic convergence. Big part of this cycle is done inside +* canonical subspaces of dimensions less than M. +* + IF( ( LOWER .OR. UPPER ) .AND. ( N.GT.MAX( 64, 4*KBL ) ) ) THEN +*[TP] The number of partition levels and the actual partition are +* tuning parameters. + N4 = N / 4 + N2 = N / 2 + N34 = 3*N4 + IF( APPLV ) THEN + q = 0 + ELSE + q = 1 + END IF +* + IF( LOWER ) THEN +* +* This works very well on lower triangular matrices, in particular +* in the framework of the preconditioned Jacobi SVD (xGEJSV). +* The idea is simple: +* [+ 0 0 0] Note that Jacobi transformations of [0 0] +* [+ + 0 0] [0 0] +* [+ + x 0] actually work on [x 0] [x 0] +* [+ + x x] [x x]. [x x] +* + CALL DGSVJ0( JOBV, M-N34, N-N34, A( N34+1, N34+1 ), LDA, + $ WORK( N34+1 ), SVA( N34+1 ), MVL, + $ V( N34*q+1, N34+1 ), LDV, EPSLN, SFMIN, TOL, + $ 2, WORK( N+1 ), LWORK-N, IERR ) +* + CALL DGSVJ0( JOBV, M-N2, N34-N2, A( N2+1, N2+1 ), LDA, + $ WORK( N2+1 ), SVA( N2+1 ), MVL, + $ V( N2*q+1, N2+1 ), LDV, EPSLN, SFMIN, TOL, 2, + $ WORK( N+1 ), LWORK-N, IERR ) +* + CALL DGSVJ1( JOBV, M-N2, N-N2, N4, A( N2+1, N2+1 ), LDA, + $ WORK( N2+1 ), SVA( N2+1 ), MVL, + $ V( N2*q+1, N2+1 ), LDV, EPSLN, SFMIN, TOL, 1, + $ WORK( N+1 ), LWORK-N, IERR ) +* + CALL DGSVJ0( JOBV, M-N4, N2-N4, A( N4+1, N4+1 ), LDA, + $ WORK( N4+1 ), SVA( N4+1 ), MVL, + $ V( N4*q+1, N4+1 ), LDV, EPSLN, SFMIN, TOL, 1, + $ WORK( N+1 ), LWORK-N, IERR ) +* + CALL DGSVJ0( JOBV, M, N4, A, LDA, WORK, SVA, MVL, V, LDV, + $ EPSLN, SFMIN, TOL, 1, WORK( N+1 ), LWORK-N, + $ IERR ) +* + CALL DGSVJ1( JOBV, M, N2, N4, A, LDA, WORK, SVA, MVL, V, + $ LDV, EPSLN, SFMIN, TOL, 1, WORK( N+1 ), + $ LWORK-N, IERR ) +* +* + ELSE IF( UPPER ) THEN +* +* + CALL DGSVJ0( JOBV, N4, N4, A, LDA, WORK, SVA, MVL, V, LDV, + $ EPSLN, SFMIN, TOL, 2, WORK( N+1 ), LWORK-N, + $ IERR ) +* + CALL DGSVJ0( JOBV, N2, N4, A( 1, N4+1 ), LDA, WORK( N4+1 ), + $ SVA( N4+1 ), MVL, V( N4*q+1, N4+1 ), LDV, + $ EPSLN, SFMIN, TOL, 1, WORK( N+1 ), LWORK-N, + $ IERR ) +* + CALL DGSVJ1( JOBV, N2, N2, N4, A, LDA, WORK, SVA, MVL, V, + $ LDV, EPSLN, SFMIN, TOL, 1, WORK( N+1 ), + $ LWORK-N, IERR ) +* + CALL DGSVJ0( JOBV, N2+N4, N4, A( 1, N2+1 ), LDA, + $ WORK( N2+1 ), SVA( N2+1 ), MVL, + $ V( N2*q+1, N2+1 ), LDV, EPSLN, SFMIN, TOL, 1, + $ WORK( N+1 ), LWORK-N, IERR ) + + END IF +* + END IF +* +* .. Row-cyclic pivot strategy with de Rijk's pivoting .. +* + DO 1993 i = 1, NSWEEP +* +* .. go go go ... +* + MXAAPQ = ZERO + MXSINJ = ZERO + ISWROT = 0 +* + NOTROT = 0 + PSKIPPED = 0 +* +* Each sweep is unrolled using KBL-by-KBL tiles over the pivot pairs +* 1 <= p < q <= N. This is the first step toward a blocked implementation +* of the rotations. New implementation, based on block transformations, +* is under development. +* + DO 2000 ibr = 1, NBL +* + igl = ( ibr-1 )*KBL + 1 +* + DO 1002 ir1 = 0, MIN( LKAHEAD, NBL-ibr ) +* + igl = igl + ir1*KBL +* + DO 2001 p = igl, MIN( igl+KBL-1, N-1 ) +* +* .. de Rijk's pivoting +* + q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1 + IF( p.NE.q ) THEN + CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 ) + IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1, + $ V( 1, q ), 1 ) + TEMP1 = SVA( p ) + SVA( p ) = SVA( q ) + SVA( q ) = TEMP1 + TEMP1 = WORK( p ) + WORK( p ) = WORK( q ) + WORK( q ) = TEMP1 + END IF +* + IF( ir1.EQ.0 ) THEN +* +* Column norms are periodically updated by explicit +* norm computation. +* Caveat: +* Unfortunately, some BLAS implementations compute DNRM2(M,A(1,p),1) +* as DSQRT(DDOT(M,A(1,p),1,A(1,p),1)), which may cause the result to +* overflow for ||A(:,p)||_2 > DSQRT(overflow_threshold), and to +* underflow for ||A(:,p)||_2 < DSQRT(underflow_threshold). +* Hence, DNRM2 cannot be trusted, not even in the case when +* the true norm is far from the under(over)flow boundaries. +* If properly implemented DNRM2 is available, the IF-THEN-ELSE +* below should read "AAPP = DNRM2( M, A(1,p), 1 ) * WORK(p)". +* + IF( ( SVA( p ).LT.ROOTBIG ) .AND. + $ ( SVA( p ).GT.ROOTSFMIN ) ) THEN + SVA( p ) = DNRM2( M, A( 1, p ), 1 )*WORK( p ) + ELSE + TEMP1 = ZERO + AAPP = ONE + CALL DLASSQ( M, A( 1, p ), 1, TEMP1, AAPP ) + SVA( p ) = TEMP1*DSQRT( AAPP )*WORK( p ) + END IF + AAPP = SVA( p ) + ELSE + AAPP = SVA( p ) + END IF +* + IF( AAPP.GT.ZERO ) THEN +* + PSKIPPED = 0 +* + DO 2002 q = p + 1, MIN( igl+KBL-1, N ) +* + AAQQ = SVA( q ) +* + IF( AAQQ.GT.ZERO ) THEN +* + AAPP0 = AAPP + IF( AAQQ.GE.ONE ) THEN + ROTOK = ( SMALL*AAPP ).LE.AAQQ + IF( AAPP.LT.( BIG / AAQQ ) ) THEN + AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, + $ q ), 1 )*WORK( p )*WORK( q ) / + $ AAQQ ) / AAPP + ELSE + CALL DCOPY( M, A( 1, p ), 1, + $ WORK( N+1 ), 1 ) + CALL DLASCL( 'G', 0, 0, AAPP, + $ WORK( p ), M, 1, + $ WORK( N+1 ), LDA, IERR ) + AAPQ = DDOT( M, WORK( N+1 ), 1, + $ A( 1, q ), 1 )*WORK( q ) / AAQQ + END IF + ELSE + ROTOK = AAPP.LE.( AAQQ / SMALL ) + IF( AAPP.GT.( SMALL / AAQQ ) ) THEN + AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, + $ q ), 1 )*WORK( p )*WORK( q ) / + $ AAQQ ) / AAPP + ELSE + CALL DCOPY( M, A( 1, q ), 1, + $ WORK( N+1 ), 1 ) + CALL DLASCL( 'G', 0, 0, AAQQ, + $ WORK( q ), M, 1, + $ WORK( N+1 ), LDA, IERR ) + AAPQ = DDOT( M, WORK( N+1 ), 1, + $ A( 1, p ), 1 )*WORK( p ) / AAPP + END IF + END IF +* + MXAAPQ = MAX( MXAAPQ, DABS( AAPQ ) ) +* +* TO rotate or NOT to rotate, THAT is the question ... +* + IF( DABS( AAPQ ).GT.TOL ) THEN +* +* .. rotate +*[RTD] ROTATED = ROTATED + ONE +* + IF( ir1.EQ.0 ) THEN + NOTROT = 0 + PSKIPPED = 0 + ISWROT = ISWROT + 1 + END IF +* + IF( ROTOK ) THEN +* + AQOAP = AAQQ / AAPP + APOAQ = AAPP / AAQQ + THETA = -HALF*DABS(AQOAP-APOAQ)/AAPQ +* + IF( DABS( THETA ).GT.BIGTHETA ) THEN +* + T = HALF / THETA + FASTR( 3 ) = T*WORK( p ) / WORK( q ) + FASTR( 4 ) = -T*WORK( q ) / + $ WORK( p ) + CALL DROTM( M, A( 1, p ), 1, + $ A( 1, q ), 1, FASTR ) + IF( RSVEC )CALL DROTM( MVL, + $ V( 1, p ), 1, + $ V( 1, q ), 1, + $ FASTR ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE+T*APOAQ*AAPQ ) ) + AAPP = AAPP*DSQRT( MAX( ZERO, + $ ONE-T*AQOAP*AAPQ ) ) + MXSINJ = MAX( MXSINJ, DABS( T ) ) +* + ELSE +* +* .. choose correct signum for THETA and rotate +* + THSIGN = -DSIGN( ONE, AAPQ ) + T = ONE / ( THETA+THSIGN* + $ DSQRT( ONE+THETA*THETA ) ) + CS = DSQRT( ONE / ( ONE+T*T ) ) + SN = T*CS +* + MXSINJ = MAX( MXSINJ, DABS( SN ) ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE+T*APOAQ*AAPQ ) ) + AAPP = AAPP*DSQRT( MAX( ZERO, + $ ONE-T*AQOAP*AAPQ ) ) +* + APOAQ = WORK( p ) / WORK( q ) + AQOAP = WORK( q ) / WORK( p ) + IF( WORK( p ).GE.ONE ) THEN + IF( WORK( q ).GE.ONE ) THEN + FASTR( 3 ) = T*APOAQ + FASTR( 4 ) = -T*AQOAP + WORK( p ) = WORK( p )*CS + WORK( q ) = WORK( q )*CS + CALL DROTM( M, A( 1, p ), 1, + $ A( 1, q ), 1, + $ FASTR ) + IF( RSVEC )CALL DROTM( MVL, + $ V( 1, p ), 1, V( 1, q ), + $ 1, FASTR ) + ELSE + CALL DAXPY( M, -T*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + CALL DAXPY( M, CS*SN*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + WORK( p ) = WORK( p )*CS + WORK( q ) = WORK( q ) / CS + IF( RSVEC ) THEN + CALL DAXPY( MVL, -T*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + CALL DAXPY( MVL, + $ CS*SN*APOAQ, + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) + END IF + END IF + ELSE + IF( WORK( q ).GE.ONE ) THEN + CALL DAXPY( M, T*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + CALL DAXPY( M, -CS*SN*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + WORK( p ) = WORK( p ) / CS + WORK( q ) = WORK( q )*CS + IF( RSVEC ) THEN + CALL DAXPY( MVL, T*APOAQ, + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) + CALL DAXPY( MVL, + $ -CS*SN*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + END IF + ELSE + IF( WORK( p ).GE.WORK( q ) ) + $ THEN + CALL DAXPY( M, -T*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + CALL DAXPY( M, CS*SN*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + WORK( p ) = WORK( p )*CS + WORK( q ) = WORK( q ) / CS + IF( RSVEC ) THEN + CALL DAXPY( MVL, + $ -T*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + CALL DAXPY( MVL, + $ CS*SN*APOAQ, + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) + END IF + ELSE + CALL DAXPY( M, T*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + CALL DAXPY( M, + $ -CS*SN*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + WORK( p ) = WORK( p ) / CS + WORK( q ) = WORK( q )*CS + IF( RSVEC ) THEN + CALL DAXPY( MVL, + $ T*APOAQ, V( 1, p ), + $ 1, V( 1, q ), 1 ) + CALL DAXPY( MVL, + $ -CS*SN*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + END IF + END IF + END IF + END IF + END IF +* + ELSE +* .. have to use modified Gram-Schmidt like transformation + CALL DCOPY( M, A( 1, p ), 1, + $ WORK( N+1 ), 1 ) + CALL DLASCL( 'G', 0, 0, AAPP, ONE, M, + $ 1, WORK( N+1 ), LDA, + $ IERR ) + CALL DLASCL( 'G', 0, 0, AAQQ, ONE, M, + $ 1, A( 1, q ), LDA, IERR ) + TEMP1 = -AAPQ*WORK( p ) / WORK( q ) + CALL DAXPY( M, TEMP1, WORK( N+1 ), 1, + $ A( 1, q ), 1 ) + CALL DLASCL( 'G', 0, 0, ONE, AAQQ, M, + $ 1, A( 1, q ), LDA, IERR ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE-AAPQ*AAPQ ) ) + MXSINJ = MAX( MXSINJ, SFMIN ) + END IF +* END IF ROTOK THEN ... ELSE +* +* In the case of cancellation in updating SVA(q), SVA(p) +* recompute SVA(q), SVA(p). +* + IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS ) + $ THEN + IF( ( AAQQ.LT.ROOTBIG ) .AND. + $ ( AAQQ.GT.ROOTSFMIN ) ) THEN + SVA( q ) = DNRM2( M, A( 1, q ), 1 )* + $ WORK( q ) + ELSE + T = ZERO + AAQQ = ONE + CALL DLASSQ( M, A( 1, q ), 1, T, + $ AAQQ ) + SVA( q ) = T*DSQRT( AAQQ )*WORK( q ) + END IF + END IF + IF( ( AAPP / AAPP0 ).LE.ROOTEPS ) THEN + IF( ( AAPP.LT.ROOTBIG ) .AND. + $ ( AAPP.GT.ROOTSFMIN ) ) THEN + AAPP = DNRM2( M, A( 1, p ), 1 )* + $ WORK( p ) + ELSE + T = ZERO + AAPP = ONE + CALL DLASSQ( M, A( 1, p ), 1, T, + $ AAPP ) + AAPP = T*DSQRT( AAPP )*WORK( p ) + END IF + SVA( p ) = AAPP + END IF +* + ELSE +* A(:,p) and A(:,q) already numerically orthogonal + IF( ir1.EQ.0 )NOTROT = NOTROT + 1 +*[RTD] SKIPPED = SKIPPED + 1 + PSKIPPED = PSKIPPED + 1 + END IF + ELSE +* A(:,q) is zero column + IF( ir1.EQ.0 )NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + END IF +* + IF( ( i.LE.SWBAND ) .AND. + $ ( PSKIPPED.GT.ROWSKIP ) ) THEN + IF( ir1.EQ.0 )AAPP = -AAPP + NOTROT = 0 + GO TO 2103 + END IF +* + 2002 CONTINUE +* END q-LOOP +* + 2103 CONTINUE +* bailed out of q-loop +* + SVA( p ) = AAPP +* + ELSE + SVA( p ) = AAPP + IF( ( ir1.EQ.0 ) .AND. ( AAPP.EQ.ZERO ) ) + $ NOTROT = NOTROT + MIN( igl+KBL-1, N ) - p + END IF +* + 2001 CONTINUE +* end of the p-loop +* end of doing the block ( ibr, ibr ) + 1002 CONTINUE +* end of ir1-loop +* +* ... go to the off diagonal blocks +* + igl = ( ibr-1 )*KBL + 1 +* + DO 2010 jbc = ibr + 1, NBL +* + jgl = ( jbc-1 )*KBL + 1 +* +* doing the block at ( ibr, jbc ) +* + IJBLSK = 0 + DO 2100 p = igl, MIN( igl+KBL-1, N ) +* + AAPP = SVA( p ) + IF( AAPP.GT.ZERO ) THEN +* + PSKIPPED = 0 +* + DO 2200 q = jgl, MIN( jgl+KBL-1, N ) +* + AAQQ = SVA( q ) + IF( AAQQ.GT.ZERO ) THEN + AAPP0 = AAPP +* +* .. M x 2 Jacobi SVD .. +* +* Safe Gram matrix computation +* + IF( AAQQ.GE.ONE ) THEN + IF( AAPP.GE.AAQQ ) THEN + ROTOK = ( SMALL*AAPP ).LE.AAQQ + ELSE + ROTOK = ( SMALL*AAQQ ).LE.AAPP + END IF + IF( AAPP.LT.( BIG / AAQQ ) ) THEN + AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, + $ q ), 1 )*WORK( p )*WORK( q ) / + $ AAQQ ) / AAPP + ELSE + CALL DCOPY( M, A( 1, p ), 1, + $ WORK( N+1 ), 1 ) + CALL DLASCL( 'G', 0, 0, AAPP, + $ WORK( p ), M, 1, + $ WORK( N+1 ), LDA, IERR ) + AAPQ = DDOT( M, WORK( N+1 ), 1, + $ A( 1, q ), 1 )*WORK( q ) / AAQQ + END IF + ELSE + IF( AAPP.GE.AAQQ ) THEN + ROTOK = AAPP.LE.( AAQQ / SMALL ) + ELSE + ROTOK = AAQQ.LE.( AAPP / SMALL ) + END IF + IF( AAPP.GT.( SMALL / AAQQ ) ) THEN + AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, + $ q ), 1 )*WORK( p )*WORK( q ) / + $ AAQQ ) / AAPP + ELSE + CALL DCOPY( M, A( 1, q ), 1, + $ WORK( N+1 ), 1 ) + CALL DLASCL( 'G', 0, 0, AAQQ, + $ WORK( q ), M, 1, + $ WORK( N+1 ), LDA, IERR ) + AAPQ = DDOT( M, WORK( N+1 ), 1, + $ A( 1, p ), 1 )*WORK( p ) / AAPP + END IF + END IF +* + MXAAPQ = MAX( MXAAPQ, DABS( AAPQ ) ) +* +* TO rotate or NOT to rotate, THAT is the question ... +* + IF( DABS( AAPQ ).GT.TOL ) THEN + NOTROT = 0 +*[RTD] ROTATED = ROTATED + 1 + PSKIPPED = 0 + ISWROT = ISWROT + 1 +* + IF( ROTOK ) THEN +* + AQOAP = AAQQ / AAPP + APOAQ = AAPP / AAQQ + THETA = -HALF*DABS(AQOAP-APOAQ)/AAPQ + IF( AAQQ.GT.AAPP0 )THETA = -THETA +* + IF( DABS( THETA ).GT.BIGTHETA ) THEN + T = HALF / THETA + FASTR( 3 ) = T*WORK( p ) / WORK( q ) + FASTR( 4 ) = -T*WORK( q ) / + $ WORK( p ) + CALL DROTM( M, A( 1, p ), 1, + $ A( 1, q ), 1, FASTR ) + IF( RSVEC )CALL DROTM( MVL, + $ V( 1, p ), 1, + $ V( 1, q ), 1, + $ FASTR ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE+T*APOAQ*AAPQ ) ) + AAPP = AAPP*DSQRT( MAX( ZERO, + $ ONE-T*AQOAP*AAPQ ) ) + MXSINJ = MAX( MXSINJ, DABS( T ) ) + ELSE +* +* .. choose correct signum for THETA and rotate +* + THSIGN = -DSIGN( ONE, AAPQ ) + IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN + T = ONE / ( THETA+THSIGN* + $ DSQRT( ONE+THETA*THETA ) ) + CS = DSQRT( ONE / ( ONE+T*T ) ) + SN = T*CS + MXSINJ = MAX( MXSINJ, DABS( SN ) ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE+T*APOAQ*AAPQ ) ) + AAPP = AAPP*DSQRT( MAX( ZERO, + $ ONE-T*AQOAP*AAPQ ) ) +* + APOAQ = WORK( p ) / WORK( q ) + AQOAP = WORK( q ) / WORK( p ) + IF( WORK( p ).GE.ONE ) THEN +* + IF( WORK( q ).GE.ONE ) THEN + FASTR( 3 ) = T*APOAQ + FASTR( 4 ) = -T*AQOAP + WORK( p ) = WORK( p )*CS + WORK( q ) = WORK( q )*CS + CALL DROTM( M, A( 1, p ), 1, + $ A( 1, q ), 1, + $ FASTR ) + IF( RSVEC )CALL DROTM( MVL, + $ V( 1, p ), 1, V( 1, q ), + $ 1, FASTR ) + ELSE + CALL DAXPY( M, -T*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + CALL DAXPY( M, CS*SN*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + IF( RSVEC ) THEN + CALL DAXPY( MVL, -T*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + CALL DAXPY( MVL, + $ CS*SN*APOAQ, + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) + END IF + WORK( p ) = WORK( p )*CS + WORK( q ) = WORK( q ) / CS + END IF + ELSE + IF( WORK( q ).GE.ONE ) THEN + CALL DAXPY( M, T*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + CALL DAXPY( M, -CS*SN*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + IF( RSVEC ) THEN + CALL DAXPY( MVL, T*APOAQ, + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) + CALL DAXPY( MVL, + $ -CS*SN*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + END IF + WORK( p ) = WORK( p ) / CS + WORK( q ) = WORK( q )*CS + ELSE + IF( WORK( p ).GE.WORK( q ) ) + $ THEN + CALL DAXPY( M, -T*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + CALL DAXPY( M, CS*SN*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + WORK( p ) = WORK( p )*CS + WORK( q ) = WORK( q ) / CS + IF( RSVEC ) THEN + CALL DAXPY( MVL, + $ -T*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + CALL DAXPY( MVL, + $ CS*SN*APOAQ, + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) + END IF + ELSE + CALL DAXPY( M, T*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + CALL DAXPY( M, + $ -CS*SN*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + WORK( p ) = WORK( p ) / CS + WORK( q ) = WORK( q )*CS + IF( RSVEC ) THEN + CALL DAXPY( MVL, + $ T*APOAQ, V( 1, p ), + $ 1, V( 1, q ), 1 ) + CALL DAXPY( MVL, + $ -CS*SN*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + END IF + END IF + END IF + END IF + END IF +* + ELSE + IF( AAPP.GT.AAQQ ) THEN + CALL DCOPY( M, A( 1, p ), 1, + $ WORK( N+1 ), 1 ) + CALL DLASCL( 'G', 0, 0, AAPP, ONE, + $ M, 1, WORK( N+1 ), LDA, + $ IERR ) + CALL DLASCL( 'G', 0, 0, AAQQ, ONE, + $ M, 1, A( 1, q ), LDA, + $ IERR ) + TEMP1 = -AAPQ*WORK( p ) / WORK( q ) + CALL DAXPY( M, TEMP1, WORK( N+1 ), + $ 1, A( 1, q ), 1 ) + CALL DLASCL( 'G', 0, 0, ONE, AAQQ, + $ M, 1, A( 1, q ), LDA, + $ IERR ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE-AAPQ*AAPQ ) ) + MXSINJ = MAX( MXSINJ, SFMIN ) + ELSE + CALL DCOPY( M, A( 1, q ), 1, + $ WORK( N+1 ), 1 ) + CALL DLASCL( 'G', 0, 0, AAQQ, ONE, + $ M, 1, WORK( N+1 ), LDA, + $ IERR ) + CALL DLASCL( 'G', 0, 0, AAPP, ONE, + $ M, 1, A( 1, p ), LDA, + $ IERR ) + TEMP1 = -AAPQ*WORK( q ) / WORK( p ) + CALL DAXPY( M, TEMP1, WORK( N+1 ), + $ 1, A( 1, p ), 1 ) + CALL DLASCL( 'G', 0, 0, ONE, AAPP, + $ M, 1, A( 1, p ), LDA, + $ IERR ) + SVA( p ) = AAPP*DSQRT( MAX( ZERO, + $ ONE-AAPQ*AAPQ ) ) + MXSINJ = MAX( MXSINJ, SFMIN ) + END IF + END IF +* END IF ROTOK THEN ... ELSE +* +* In the case of cancellation in updating SVA(q) +* .. recompute SVA(q) + IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS ) + $ THEN + IF( ( AAQQ.LT.ROOTBIG ) .AND. + $ ( AAQQ.GT.ROOTSFMIN ) ) THEN + SVA( q ) = DNRM2( M, A( 1, q ), 1 )* + $ WORK( q ) + ELSE + T = ZERO + AAQQ = ONE + CALL DLASSQ( M, A( 1, q ), 1, T, + $ AAQQ ) + SVA( q ) = T*DSQRT( AAQQ )*WORK( q ) + END IF + END IF + IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN + IF( ( AAPP.LT.ROOTBIG ) .AND. + $ ( AAPP.GT.ROOTSFMIN ) ) THEN + AAPP = DNRM2( M, A( 1, p ), 1 )* + $ WORK( p ) + ELSE + T = ZERO + AAPP = ONE + CALL DLASSQ( M, A( 1, p ), 1, T, + $ AAPP ) + AAPP = T*DSQRT( AAPP )*WORK( p ) + END IF + SVA( p ) = AAPP + END IF +* end of OK rotation + ELSE + NOTROT = NOTROT + 1 +*[RTD] SKIPPED = SKIPPED + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF + ELSE + NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF +* + IF( ( i.LE.SWBAND ) .AND. ( IJBLSK.GE.BLSKIP ) ) + $ THEN + SVA( p ) = AAPP + NOTROT = 0 + GO TO 2011 + END IF + IF( ( i.LE.SWBAND ) .AND. + $ ( PSKIPPED.GT.ROWSKIP ) ) THEN + AAPP = -AAPP + NOTROT = 0 + GO TO 2203 + END IF +* + 2200 CONTINUE +* end of the q-loop + 2203 CONTINUE +* + SVA( p ) = AAPP +* + ELSE +* + IF( AAPP.EQ.ZERO )NOTROT = NOTROT + + $ MIN( jgl+KBL-1, N ) - jgl + 1 + IF( AAPP.LT.ZERO )NOTROT = 0 +* + END IF +* + 2100 CONTINUE +* end of the p-loop + 2010 CONTINUE +* end of the jbc-loop + 2011 CONTINUE +*2011 bailed out of the jbc-loop + DO 2012 p = igl, MIN( igl+KBL-1, N ) + SVA( p ) = DABS( SVA( p ) ) + 2012 CONTINUE +*** + 2000 CONTINUE +*2000 :: end of the ibr-loop +* +* .. update SVA(N) + IF( ( SVA( N ).LT.ROOTBIG ) .AND. ( SVA( N ).GT.ROOTSFMIN ) ) + $ THEN + SVA( N ) = DNRM2( M, A( 1, N ), 1 )*WORK( N ) + ELSE + T = ZERO + AAPP = ONE + CALL DLASSQ( M, A( 1, N ), 1, T, AAPP ) + SVA( N ) = T*DSQRT( AAPP )*WORK( N ) + END IF +* +* Additional steering devices +* + IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. + $ ( ISWROT.LE.N ) ) )SWBAND = i +* + IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.DSQRT( DBLE( N ) )* + $ TOL ) .AND. ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN + GO TO 1994 + END IF +* + IF( NOTROT.GE.EMPTSW )GO TO 1994 +* + 1993 CONTINUE +* end i=1:NSWEEP loop +* +* #:( Reaching this point means that the procedure has not converged. + INFO = NSWEEP - 1 + GO TO 1995 +* + 1994 CONTINUE +* #:) Reaching this point means numerical convergence after the i-th +* sweep. +* + INFO = 0 +* #:) INFO = 0 confirms successful iterations. + 1995 CONTINUE +* +* Sort the singular values and find how many are above +* the underflow threshold. +* + N2 = 0 + N4 = 0 + DO 5991 p = 1, N - 1 + q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1 + IF( p.NE.q ) THEN + TEMP1 = SVA( p ) + SVA( p ) = SVA( q ) + SVA( q ) = TEMP1 + TEMP1 = WORK( p ) + WORK( p ) = WORK( q ) + WORK( q ) = TEMP1 + CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 ) + IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1, V( 1, q ), 1 ) + END IF + IF( SVA( p ).NE.ZERO ) THEN + N4 = N4 + 1 + IF( SVA( p )*SKL.GT.SFMIN )N2 = N2 + 1 + END IF + 5991 CONTINUE + IF( SVA( N ).NE.ZERO ) THEN + N4 = N4 + 1 + IF( SVA( N )*SKL.GT.SFMIN )N2 = N2 + 1 + END IF +* +* Normalize the left singular vectors. +* + IF( LSVEC .OR. UCTOL ) THEN + DO 1998 p = 1, N2 + CALL DSCAL( M, WORK( p ) / SVA( p ), A( 1, p ), 1 ) + 1998 CONTINUE + END IF +* +* Scale the product of Jacobi rotations (assemble the fast rotations). +* + IF( RSVEC ) THEN + IF( APPLV ) THEN + DO 2398 p = 1, N + CALL DSCAL( MVL, WORK( p ), V( 1, p ), 1 ) + 2398 CONTINUE + ELSE + DO 2399 p = 1, N + TEMP1 = ONE / DNRM2( MVL, V( 1, p ), 1 ) + CALL DSCAL( MVL, TEMP1, V( 1, p ), 1 ) + 2399 CONTINUE + END IF + END IF +* +* Undo scaling, if necessary (and possible). + IF( ( ( SKL.GT.ONE ) .AND. ( SVA( 1 ).LT.( BIG / SKL) ) ) + $ .OR. ( ( SKL.LT.ONE ) .AND. ( SVA( MAX( N2, 1 ) ) .GT. + $ ( SFMIN / SKL) ) ) ) THEN + DO 2400 p = 1, N + SVA( P ) = SKL*SVA( P ) + 2400 CONTINUE + SKL= ONE + END IF +* + WORK( 1 ) = SKL +* The singular values of A are SKL*SVA(1:N). If SKL.NE.ONE +* then some of the singular values may overflow or underflow and +* the spectrum is given in this factored representation. +* + WORK( 2 ) = DBLE( N4 ) +* N4 is the number of computed nonzero singular values of A. +* + WORK( 3 ) = DBLE( N2 ) +* N2 is the number of singular values of A greater than SFMIN. +* If N2 \brief DGESVX computes the solution to system of linear equations A * X = B for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGESVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, +* EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, +* WORK, IWORK, INFO ) +* +* .. 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +*> \par Description: +* ================= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is 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. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] AF +*> \verbatim +*> AF is 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). +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] IPIV +*> \verbatim +*> IPIV is 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. +*> \endverbatim +*> +*> \param[in,out] EQUED +*> \verbatim +*> EQUED is 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. +*> \endverbatim +*> +*> \param[in,out] R +*> \verbatim +*> R is 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. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is 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. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, +*> if 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is 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'. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is 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. +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is 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 WORK(1) contains the reciprocal pivot growth factor for the +*> leading INFO columns of A. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleGEsolve +* +* ===================================================================== + 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.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. 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, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dgesvxx.f b/math/lapack/src/main/fortran/dgesvxx.f new file mode 100644 index 0000000000..afcd05d8ea --- /dev/null +++ b/math/lapack/src/main/fortran/dgesvxx.f @@ -0,0 +1,769 @@ +*> \brief DGESVXX computes the solution to system of linear equations A * X = B for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGESVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, +* EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, +* BERR, N_ERR_BNDS, ERR_BNDS_NORM, +* ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER EQUED, FACT, TRANS +* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, +* $ N_ERR_BNDS +* DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), +* $ X( LDX , * ),WORK( * ) +* DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), +* $ ERR_BNDS_NORM( NRHS, * ), +* $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGESVXX uses the LU factorization to compute the solution to a +*> double precision system of linear equations A * X = B, where A is an +*> N-by-N matrix and X and B are N-by-NRHS matrices. +*> +*> If requested, both normwise and maximum componentwise error bounds +*> are returned. DGESVXX will return a solution with a tiny +*> guaranteed error (O(eps) where eps is the working machine +*> precision) unless the matrix is very ill-conditioned, in which +*> case a warning is returned. Relevant condition numbers also are +*> calculated and returned. +*> +*> DGESVXX accepts user-provided factorizations and equilibration +*> factors; see the definitions of the FACT and EQUED options. +*> Solving with refinement and using a factorization from a previous +*> DGESVXX call will also produce a solution with either O(eps) +*> errors or warnings, but we cannot make that claim for general +*> user-provided factorizations and equilibration factors if they +*> differ from what DGESVXX would itself produce. +*> \endverbatim +* +*> \par Description: +* ================= +*> +*> \verbatim +*> +*> The following steps are performed: +*> +*> 1. If FACT = 'E', double precision scaling factors are computed to equilibrate +*> the system: +*> +*> TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +*> TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +*> TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +*> +*> Whether or not the system will be equilibrated depends on the +*> scaling of the matrix A, but if equilibration is used, A is +*> overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') +*> or diag(C)*B (if TRANS = 'T' or 'C'). +*> +*> 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +*> the matrix A (after equilibration if FACT = 'E') as +*> +*> A = P * L * U, +*> +*> where P is a permutation matrix, L is a unit lower triangular +*> matrix, and U is upper triangular. +*> +*> 3. If some U(i,i)=0, so that U is exactly singular, then the +*> routine returns with INFO = i. Otherwise, the factored form of A +*> is used to estimate the condition number of the matrix A (see +*> argument RCOND). If the reciprocal of the condition number is less +*> than machine precision, the routine still goes on to solve for X +*> and compute error bounds as described below. +*> +*> 4. The system of equations is solved for X using the factored form +*> of A. +*> +*> 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +*> the routine will use iterative refinement to try to get a small +*> error and error bounds. Refinement calculates the residual to at +*> least twice the working precision. +*> +*> 6. If equilibration was used, the matrix X is premultiplied by +*> diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so +*> that it solves the original system before equilibration. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> Some optional parameters are bundled in the PARAMS array. These +*> settings determine how refinement is performed, but often the +*> defaults are acceptable. If the defaults are acceptable, users +*> can pass NPARAMS = 0 which prevents the source code from accessing +*> the PARAMS argument. +*> \endverbatim +*> +*> \param[in] FACT +*> \verbatim +*> FACT is 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. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] AF +*> \verbatim +*> AF is 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). +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] IPIV +*> \verbatim +*> IPIV is 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. +*> \endverbatim +*> +*> \param[in,out] EQUED +*> \verbatim +*> EQUED is 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. +*> \endverbatim +*> +*> \param[in,out] R +*> \verbatim +*> R is DOUBLE PRECISION array, dimension (N) +*> The row scale factors for A. If EQUED = 'R' or 'B', A is +*> multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +*> is not accessed. R is an input argument if FACT = 'F'; +*> otherwise, R is an output argument. If FACT = 'F' and +*> EQUED = 'R' or 'B', each element of R must be positive. +*> If R is output, each element of R is a power of the radix. +*> If R is input, each element of R should be a power of the radix +*> to ensure a reliable solution and error estimates. Scaling by +*> powers of the radix does not cause rounding errors unless the +*> result underflows or overflows. Rounding errors during scaling +*> lead to refining with a matrix that is not equivalent to the +*> input matrix, producing error estimates that may not be +*> reliable. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> The column scale factors for A. If EQUED = 'C' or 'B', A is +*> multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +*> is not accessed. C is an input argument if FACT = 'F'; +*> otherwise, C is an output argument. If FACT = 'F' and +*> EQUED = 'C' or 'B', each element of C must be positive. +*> If C is output, each element of C is a power of the radix. +*> If C is input, each element of C should be a power of the radix +*> to ensure a reliable solution and error estimates. Scaling by +*> powers of the radix does not cause rounding errors unless the +*> result underflows or overflows. Rounding errors during scaling +*> lead to refining with a matrix that is not equivalent to the +*> input matrix, producing error estimates that may not be +*> reliable. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, +*> if 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> If INFO = 0, the N-by-NRHS solution matrix X to the original +*> system of equations. Note that A and B are modified on exit +*> if EQUED .ne. 'N', and the solution to the equilibrated system is +*> inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or +*> inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> Reciprocal scaled condition number. This is an estimate of the +*> reciprocal Skeel condition number of the matrix A after +*> equilibration (if done). If this is less than the machine +*> precision (in particular, if it is zero), the matrix is singular +*> to working precision. Note that the error may still be small even +*> if this number is very small and the matrix appears ill- +*> conditioned. +*> \endverbatim +*> +*> \param[out] RPVGRW +*> \verbatim +*> RPVGRW is DOUBLE PRECISION +*> Reciprocal pivot growth. On exit, this contains the reciprocal +*> pivot growth factor norm(A)/norm(U). The "max absolute element" +*> norm is used. If this is much less than 1, then the stability of +*> the LU factorization of the (equilibrated) matrix A could be poor. +*> This also means that the solution X, estimated condition numbers, +*> and error bounds could be unreliable. If factorization fails with +*> 0 for the leading INFO columns of A. In DGESVX, this quantity is +*> returned in WORK(1). +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is DOUBLE PRECISION array, dimension (NRHS) +*> Componentwise relative backward error. This is the +*> componentwise relative backward error of each solution vector X(j) +*> (i.e., the smallest relative change in any element of A or B that +*> makes X(j) an exact solution). +*> \endverbatim +*> +*> \param[in] N_ERR_BNDS +*> \verbatim +*> N_ERR_BNDS is INTEGER +*> Number of error bounds to return for each right hand side +*> and each type (normwise or componentwise). See ERR_BNDS_NORM and +*> ERR_BNDS_COMP below. +*> \endverbatim +*> +*> \param[out] ERR_BNDS_NORM +*> \verbatim +*> ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> normwise relative error, which is defined as follows: +*> +*> Normwise relative error in the ith solution vector: +*> max_j (abs(XTRUE(j,i) - X(j,i))) +*> ------------------------------ +*> max_j abs(X(j,i)) +*> +*> The array is indexed by the type of error information as described +*> below. There currently are up to three pieces of information +*> returned. +*> +*> The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_NORM(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * dlamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * dlamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated normwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * dlamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*A, where S scales each row by a power of the +*> radix so all absolute row sums of Z are approximately 1. +*> +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[out] ERR_BNDS_COMP +*> \verbatim +*> ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> componentwise relative error, which is defined as follows: +*> +*> Componentwise relative error in the ith solution vector: +*> abs(XTRUE(j,i) - X(j,i)) +*> max_j ---------------------- +*> abs(X(j,i)) +*> +*> The array is indexed by the right-hand side i (on which the +*> componentwise relative error depends), and the type of error +*> information as described below. There currently are up to three +*> pieces of information returned for each right-hand side. If +*> componentwise accuracy is not requested (PARAMS(3) = 0.0), then +*> ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +*> the first (:,N_ERR_BNDS) entries are returned. +*> +*> The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_COMP(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * dlamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * dlamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated componentwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * dlamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*(A*diag(x)), where x is the solution for the +*> current right-hand side and S scales each row of +*> A*diag(x) by a power of the radix so all absolute row +*> sums of Z are approximately 1. +*> +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[in] NPARAMS +*> \verbatim +*> NPARAMS is INTEGER +*> Specifies the number of parameters set in PARAMS. If .LE. 0, the +*> PARAMS array is never referenced and default values are used. +*> \endverbatim +*> +*> \param[in,out] PARAMS +*> \verbatim +*> PARAMS is DOUBLE PRECISION array, dimension (NPARAMS) +*> Specifies algorithm parameters. If an entry is .LT. 0.0, then +*> that entry will be filled with default value used for that +*> parameter. Only positions up to NPARAMS are accessed; defaults +*> are used for higher-numbered parameters. +*> +*> PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +*> refinement or not. +*> Default: 1.0D+0 +*> = 0.0 : No refinement is performed, and no error bounds are +*> computed. +*> = 1.0 : Use the extra-precise refinement algorithm. +*> (other values are reserved for future use) +*> +*> PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +*> computations allowed for refinement. +*> Default: 10 +*> Aggressive: Set to 100 to permit convergence using approximate +*> factorizations or factorizations other than LU. If +*> the factorization uses a technique other than +*> Gaussian elimination, the guarantees in +*> err_bnds_norm and err_bnds_comp may no longer be +*> trustworthy. +*> +*> PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +*> will attempt to find a solution with small componentwise +*> relative error in the double-precision algorithm. Positive +*> is true, 0.0 is false. +*> Default: 1.0 (attempt componentwise convergence) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Successful exit. The solution to every right-hand side is +*> guaranteed. +*> < 0: If INFO = -i, the i-th argument had an illegal value +*> > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +*> has been completed, but the factor U is exactly singular, so +*> the solution and error bounds could not be computed. RCOND = 0 +*> is returned. +*> = N+J: The solution corresponding to the Jth right-hand side is +*> not guaranteed. The solutions corresponding to other right- +*> hand sides K with K > J may not be guaranteed as well, but +*> only the first such right-hand side is reported. If a small +*> componentwise error is not requested (PARAMS(3) = 0.0) then +*> the Jth right-hand side is the first with a normwise error +*> bound that is not guaranteed (the smallest J such +*> that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +*> the Jth right-hand side is the first with either a normwise or +*> componentwise error bound that is not guaranteed (the smallest +*> J such that either ERR_BNDS_NORM(J,1) = 0.0 or +*> ERR_BNDS_COMP(J,1) = 0.0). See the definition of +*> ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +*> about all of the right-hand sides check ERR_BNDS_NORM or +*> ERR_BNDS_COMP. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleGEsolve +* +* ===================================================================== + SUBROUTINE DGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, + $ BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, + $ INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, TRANS + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX , * ),WORK( * ) + DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU + INTEGER INFEQU, J + DOUBLE PRECISION AMAX, BIGNUM, COLCND, RCMAX, RCMIN, ROWCND, + $ SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, DLAMCH, DLA_GERPVGRW + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLA_GERPVGRW +* .. +* .. External Subroutines .. + EXTERNAL DGEEQUB, DGETRF, DGETRS, DLACPY, DLAQGE, + $ XERBLA, DLASCL2, DGERFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + NOTRAN = LSAME( TRANS, 'N' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + ROWEQU = .FALSE. + COLEQU = .FALSE. + ELSE + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in DGERFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until DGERFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -10 + ELSE + IF( ROWEQU ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 10 J = 1, N + RCMIN = MIN( RCMIN, R( J ) ) + RCMAX = MAX( RCMAX, R( J ) ) + 10 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -11 + ELSE IF( N.GT.0 ) THEN + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + ROWCND = ONE + END IF + END IF + IF( COLEQU .AND. INFO.EQ.0 ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 20 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 20 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -12 + ELSE IF( N.GT.0 ) THEN + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + COLCND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGESVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL DGEEQUB( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL DLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ EQUED ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* If the scaling factors are not applied, set them to 1.0. +* + IF ( .NOT.ROWEQU ) THEN + DO J = 1, N + R( J ) = 1.0D+0 + END DO + END IF + IF ( .NOT.COLEQU ) THEN + DO J = 1, N + C( J ) = 1.0D+0 + END DO + END IF + END IF +* +* Scale the right-hand side. +* + IF( NOTRAN ) THEN + IF( ROWEQU ) CALL DLASCL2( N, NRHS, R, B, LDB ) + ELSE + IF( COLEQU ) CALL DLASCL2( N, NRHS, C, B, LDB ) + END IF +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF ) + CALL DGETRF( N, N, AF, LDAF, IPIV, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + RPVGRW = DLA_GERPVGRW( N, INFO, A, LDA, AF, LDAF ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + RPVGRW = DLA_GERPVGRW( N, N, A, LDA, AF, LDAF ) +* +* Compute the solution matrix X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL DGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, + $ IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* Scale solutions. +* + IF ( COLEQU .AND. NOTRAN ) THEN + CALL DLASCL2 ( N, NRHS, C, X, LDX ) + ELSE IF ( ROWEQU .AND. .NOT.NOTRAN ) THEN + CALL DLASCL2 ( N, NRHS, R, X, LDX ) + END IF +* + RETURN +* +* End of DGESVXX + + END diff --git a/math/lapack/src/main/fortran/dgetc2.f b/math/lapack/src/main/fortran/dgetc2.f new file mode 100644 index 0000000000..d850bc628b --- /dev/null +++ b/math/lapack/src/main/fortran/dgetc2.f @@ -0,0 +1,234 @@ +*> \brief \b DGETC2 computes the LU factorization with complete pivoting of the general n-by-n matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGETC2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), JPIV( * ) +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension(N). +*> The pivot indices; for 1 <= i <= N, row i of the +*> matrix has been interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension(N). +*> The pivot indices; for 1 <= j <= N, column j of the +*> matrix has been interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleGEauxiliary +* +*> \par Contributors: +* ================== +*> +*> Bo Kagstrom and Peter Poromaa, Department of Computing Science, +*> Umea University, S-901 87 Umea, Sweden. +* +* ===================================================================== + SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. 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 .. +* + INFO = 0 +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Set constants to control overflow +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* +* Handle the case N=1 by itself +* + IF( N.EQ.1 ) THEN + IPIV( 1 ) = 1 + JPIV( 1 ) = 1 + IF( ABS( A( 1, 1 ) ).LT.SMLNUM ) THEN + INFO = 1 + A( 1, 1 ) = SMLNUM + END IF + RETURN + END IF +* +* 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 +* +* Set last pivots to N +* + IPIV( N ) = N + JPIV( N ) = N +* + RETURN +* +* End of DGETC2 +* + END diff --git a/math/lapack/src/main/fortran/dgetf2.f b/math/lapack/src/main/fortran/dgetf2.f new file mode 100644 index 0000000000..5458a5f3eb --- /dev/null +++ b/math/lapack/src/main/fortran/dgetf2.f @@ -0,0 +1,213 @@ +*> \brief \b DGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row interchanges (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGETF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the m by n matrix 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is 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). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> > 0: if INFO = k, 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dgetrf.f b/math/lapack/src/main/fortran/dgetrf.f new file mode 100644 index 0000000000..9a340b60f3 --- /dev/null +++ b/math/lapack/src/main/fortran/dgetrf.f @@ -0,0 +1,225 @@ +*> \brief \b DGETRF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGETRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is 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). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IINFO, J, JB, NB +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGETRF2, 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 DGETRF2( 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 DGETRF2( 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/math/lapack/src/main/fortran/dgetrf2.f b/math/lapack/src/main/fortran/dgetrf2.f new file mode 100644 index 0000000000..77948d2305 --- /dev/null +++ b/math/lapack/src/main/fortran/dgetrf2.f @@ -0,0 +1,272 @@ +*> \brief \b DGETRF2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGETRF2 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 recursive version of the algorithm. It divides +*> the matrix into four submatrices: +*> +*> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 +*> A = [ -----|----- ] with n1 = min(m,n)/2 +*> [ A21 | A22 ] n2 = n-n1 +*> +*> [ A11 ] +*> The subroutine calls itself to factor [ --- ], +*> [ A12 ] +*> [ A12 ] +*> do the swaps on [ --- ], solve A12, update A22, +*> [ A22 ] +*> +*> then calls itself to factor A22 and do the swaps on A21. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is 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). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION SFMIN, TEMP + INTEGER I, IINFO, N1, N2 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER IDAMAX + EXTERNAL DLAMCH, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DSCAL, DLASWP, DTRSM, 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( 'DGETRF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN + + IF ( M.EQ.1 ) THEN +* +* Use unblocked code for one row case +* Just need to handle IPIV and INFO +* + IPIV( 1 ) = 1 + IF ( A(1,1).EQ.ZERO ) + $ INFO = 1 +* + ELSE IF( N.EQ.1 ) THEN +* +* Use unblocked code for one column case +* +* +* Compute machine safe minimum +* + SFMIN = DLAMCH('S') +* +* Find pivot and test for singularity +* + I = IDAMAX( M, A( 1, 1 ), 1 ) + IPIV( 1 ) = I + IF( A( I, 1 ).NE.ZERO ) THEN +* +* Apply the interchange +* + IF( I.NE.1 ) THEN + TEMP = A( 1, 1 ) + A( 1, 1 ) = A( I, 1 ) + A( I, 1 ) = TEMP + END IF +* +* Compute elements 2:M of the column +* + IF( ABS(A( 1, 1 )) .GE. SFMIN ) THEN + CALL DSCAL( M-1, ONE / A( 1, 1 ), A( 2, 1 ), 1 ) + ELSE + DO 10 I = 1, M-1 + A( 1+I, 1 ) = A( 1+I, 1 ) / A( 1, 1 ) + 10 CONTINUE + END IF +* + ELSE + INFO = 1 + END IF +* + ELSE +* +* Use recursive code +* + N1 = MIN( M, N ) / 2 + N2 = N-N1 +* +* [ A11 ] +* Factor [ --- ] +* [ A21 ] +* + CALL DGETRF2( M, N1, A, LDA, IPIV, IINFO ) + + IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* [ A12 ] +* Apply interchanges to [ --- ] +* [ A22 ] +* + CALL DLASWP( N2, A( 1, N1+1 ), LDA, 1, N1, IPIV, 1 ) +* +* Solve A12 +* + CALL DTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, + $ A( 1, N1+1 ), LDA ) +* +* Update A22 +* + CALL DGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, + $ A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA ) +* +* Factor A22 +* + CALL DGETRF2( M-N1, N2, A( N1+1, N1+1 ), LDA, IPIV( N1+1 ), + $ IINFO ) +* +* Adjust INFO and the pivot indices +* + IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + N1 + DO 20 I = N1+1, MIN( M, N ) + IPIV( I ) = IPIV( I ) + N1 + 20 CONTINUE +* +* Apply interchanges to A21 +* + CALL DLASWP( N1, A( 1, 1 ), LDA, N1+1, MIN( M, N), IPIV, 1 ) +* + END IF + RETURN +* +* End of DGETRF2 +* + END diff --git a/math/lapack/src/main/fortran/dgetri.f b/math/lapack/src/main/fortran/dgetri.f new file mode 100644 index 0000000000..9d8cf2ad3e --- /dev/null +++ b/math/lapack/src/main/fortran/dgetri.f @@ -0,0 +1,261 @@ +*> \brief \b DGETRI +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGETRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from DGETRF; for 1<=i<=N, row i of the +*> matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO=0, then WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, U(i,i) is exactly zero; the matrix is +*> singular and its inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dgetrs.f b/math/lapack/src/main/fortran/dgetrs.f new file mode 100644 index 0000000000..7ac727776e --- /dev/null +++ b/math/lapack/src/main/fortran/dgetrs.f @@ -0,0 +1,225 @@ +*> \brief \b DGETRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGETRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGETRS solves a system of linear equations +*> A * X = B or A**T * X = B +*> with a general N-by-N matrix A using the LU factorization computed +*> by DGETRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the form of the system of equations: +*> = 'N': A * X = B (No transpose) +*> = 'T': A**T* X = B (Transpose) +*> = 'C': A**T* X = B (Conjugate transpose = Transpose) +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The factors L and U from the factorization A = P*L*U +*> as computed by DGETRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from DGETRF; for 1<=i<=N, row i of the +*> matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. 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**T * X = B. +* +* Solve U**T *X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve L**T *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/math/lapack/src/main/fortran/dgetsls.f b/math/lapack/src/main/fortran/dgetsls.f new file mode 100644 index 0000000000..ca0ef777be --- /dev/null +++ b/math/lapack/src/main/fortran/dgetsls.f @@ -0,0 +1,494 @@ +* Definition: +* =========== +* +* SUBROUTINE DGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB, +* $ WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGETSLS solves overdetermined or underdetermined real linear systems +*> involving an M-by-N matrix A, using a tall skinny QR or short wide 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': the linear system involves A; +*> = 'T': the linear system involves A**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrices B and X. NRHS >=0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, +*> A is overwritten by details of its QR or LQ +*> factorization as returned by DGEQR or DGELQ. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is 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. +*> 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= MAX(1,M,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) contains optimal (or either minimal +*> or optimal, if query was assumed) LWORK. +*> See LWORK for details. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1 or -2, then a workspace query is assumed. +*> If LWORK = -1, the routine calculates optimal size of WORK for the +*> optimal performance and returns this value in WORK(1). +*> If LWORK = -2, the routine calculates minimal size of WORK and +*> returns this value in WORK(1). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEsolve +* +* ===================================================================== + SUBROUTINE DGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, TRAN + INTEGER I, IASCL, IBSCL, J, MINMN, MAXMN, BROW, + $ SCLLEN, MNK, TSZO, TSZM, LWO, LWM, LW1, LW2, + $ WSIZEO, WSIZEM, INFO2 + DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM, TQ( 5 ), WORKQ +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, ILAENV, DLABAD, DLAMCH, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL DGEQR, DGEMQR, DLASCL, DLASET, + $ DTRTRS, XERBLA, DGELQ, DGEMLQ +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN, INT +* .. +* .. Executable Statements .. +* +* Test the input arguments. +* + INFO = 0 + MINMN = MIN( M, N ) + MAXMN = MAX( M, N ) + MNK = MAX( MINMN, NRHS ) + TRAN = LSAME( TRANS, 'T' ) +* + LQUERY = ( LWORK.EQ.-1 .OR. LWORK.EQ.-2 ) + 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 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size and minimum LWORK +* + IF( M.GE.N ) THEN + CALL DGEQR( M, N, A, LDA, TQ, -1, WORKQ, -1, INFO2 ) + TSZO = INT( TQ( 1 ) ) + LWO = INT( WORKQ ) + CALL DGEMQR( 'L', TRANS, M, NRHS, N, A, LDA, TQ, + $ TSZO, B, LDB, WORKQ, -1, INFO2 ) + LWO = MAX( LWO, INT( WORKQ ) ) + CALL DGEQR( M, N, A, LDA, TQ, -2, WORKQ, -2, INFO2 ) + TSZM = INT( TQ( 1 ) ) + LWM = INT( WORKQ ) + CALL DGEMQR( 'L', TRANS, M, NRHS, N, A, LDA, TQ, + $ TSZM, B, LDB, WORKQ, -1, INFO2 ) + LWM = MAX( LWM, INT( WORKQ ) ) + WSIZEO = TSZO + LWO + WSIZEM = TSZM + LWM + ELSE + CALL DGELQ( M, N, A, LDA, TQ, -1, WORKQ, -1, INFO2 ) + TSZO = INT( TQ( 1 ) ) + LWO = INT( WORKQ ) + CALL DGEMLQ( 'L', TRANS, N, NRHS, M, A, LDA, TQ, + $ TSZO, B, LDB, WORKQ, -1, INFO2 ) + LWO = MAX( LWO, INT( WORKQ ) ) + CALL DGELQ( M, N, A, LDA, TQ, -2, WORKQ, -2, INFO2 ) + TSZM = INT( TQ( 1 ) ) + LWM = INT( WORKQ ) + CALL DGEMLQ( 'L', TRANS, N, NRHS, M, A, LDA, TQ, + $ TSZO, B, LDB, WORKQ, -1, INFO2 ) + LWM = MAX( LWM, INT( WORKQ ) ) + WSIZEO = TSZO + LWO + WSIZEM = TSZM + LWM + END IF +* + IF( ( LWORK.LT.WSIZEM ).AND.( .NOT.LQUERY ) ) THEN + INFO = -10 + END IF +* + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETSLS', -INFO ) + WORK( 1 ) = DBLE( WSIZEO ) + RETURN + END IF + IF( LQUERY ) THEN + IF( LWORK.EQ.-1 ) WORK( 1 ) = REAL( WSIZEO ) + IF( LWORK.EQ.-2 ) WORK( 1 ) = REAL( WSIZEM ) + RETURN + END IF + IF( LWORK.LT.WSIZEO ) THEN + LW1 = TSZM + LW2 = LWM + ELSE + LW1 = TSZO + LW2 = LWO + 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, 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', MAXMN, NRHS, ZERO, ZERO, B, LDB ) + GO TO 50 + END IF +* + BROW = M + IF ( TRAN ) THEN + BROW = N + END IF + BNRM = DLANGE( 'M', BROW, 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, 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 DGEQR( M, N, A, LDA, WORK( LW2+1 ), LW1, + $ WORK( 1 ), LW2, INFO ) + IF ( .NOT.TRAN ) THEN +* +* Least-Squares Problem min || A * X - B || +* +* B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS) +* + CALL DGEMQR( 'L' , 'T', M, NRHS, N, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* +* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) +* + CALL DTRTRS( 'U', 'N', 'N', N, NRHS, + $ A, LDA, B, LDB, INFO ) + IF( INFO.GT.0 ) THEN + RETURN + END IF + SCLLEN = N + ELSE +* +* Overdetermined system of equations A**T * X = B +* +* B(1:N,1:NRHS) := inv(R**T) * B(1:N,1:NRHS) +* + CALL DTRTRS( 'U', 'T', 'N', 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 DGEMQR( 'L', 'N', M, NRHS, N, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* + SCLLEN = M +* + END IF +* + ELSE +* +* Compute LQ factorization of A +* + CALL DGELQ( M, N, A, LDA, WORK( LW2+1 ), LW1, + $ WORK( 1 ), LW2, INFO ) +* +* workspace at least M, optimally M*NB. +* + IF( .NOT.TRAN ) THEN +* +* underdetermined system of equations A * X = B +* +* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) +* + CALL DTRTRS( 'L', 'N', 'N', 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,:)**T * B(1:M,1:NRHS) +* + CALL DGEMLQ( 'L', 'T', N, NRHS, M, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* +* workspace at least NRHS, optimally NRHS*NB +* + SCLLEN = N +* + ELSE +* +* overdetermined system min || A**T * X - B || +* +* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) +* + CALL DGEMLQ( 'L', 'N', N, NRHS, M, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* +* workspace at least NRHS, optimally NRHS*NB +* +* B(1:M,1:NRHS) := inv(L**T) * 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( TSZO + LWO ) + RETURN +* +* End of DGETSLS +* + END diff --git a/math/lapack/src/main/fortran/dggbak.f b/math/lapack/src/main/fortran/dggbak.f new file mode 100644 index 0000000000..cd5c26064b --- /dev/null +++ b/math/lapack/src/main/fortran/dggbak.f @@ -0,0 +1,306 @@ +*> \brief \b DGGBAK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGBAK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, +* LDV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOB, SIDE +* INTEGER IHI, ILO, INFO, LDV, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION LSCALE( * ), RSCALE( * ), V( LDV, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is 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. +*> \endverbatim +*> +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'R': V contains right eigenvectors; +*> = 'L': V contains left eigenvectors. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows of the matrix V. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> The integers ILO and IHI determined by DGGBAL. +*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +*> \endverbatim +*> +*> \param[in] LSCALE +*> \verbatim +*> LSCALE is 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. +*> \endverbatim +*> +*> \param[in] RSCALE +*> \verbatim +*> RSCALE is 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. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of columns of the matrix V. M >= 0. +*> \endverbatim +*> +*> \param[in,out] V +*> \verbatim +*> V is 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. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the matrix V. LDV >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> See R.C. Ward, Balancing the generalized eigenvalue problem, +*> SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, + $ LDV, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOB, SIDE + INTEGER IHI, ILO, INFO, LDV, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION LSCALE( * ), RSCALE( * ), V( LDV, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LEFTV, RIGHTV + INTEGER I, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, INT +* .. +* .. 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 = INT(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 = INT(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 = INT(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 = INT(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/math/lapack/src/main/fortran/dggbal.f b/math/lapack/src/main/fortran/dggbal.f new file mode 100644 index 0000000000..5f36aa024b --- /dev/null +++ b/math/lapack/src/main/fortran/dggbal.f @@ -0,0 +1,559 @@ +*> \brief \b DGGBAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGBAL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, +* RSCALE, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOB +* INTEGER IHI, ILO, INFO, LDA, LDB, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), LSCALE( * ), +* $ RSCALE( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[out] IHI +*> \verbatim +*> IHI is 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. +*> \endverbatim +*> +*> \param[out] LSCALE +*> \verbatim +*> LSCALE is 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. +*> \endverbatim +*> +*> \param[out] RSCALE +*> \verbatim +*> RSCALE is 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. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION 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'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> See R.C. WARD, Balancing the generalized eigenvalue problem, +*> SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, + $ RSCALE, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOB + INTEGER IHI, ILO, INFO, LDA, LDB, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), LSCALE( * ), + $ RSCALE( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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 = INT(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 = INT(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/math/lapack/src/main/fortran/dgges.f b/math/lapack/src/main/fortran/dgges.f new file mode 100644 index 0000000000..097ea77275 --- /dev/null +++ b/math/lapack/src/main/fortran/dgges.f @@ -0,0 +1,682 @@ +*> \brief DGGES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGES + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, +* SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, +* LDVSR, WORK, LWORK, BWORK, INFO ) +* +* .. 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 SELCTG +* EXTERNAL SELCTG +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVSL +*> \verbatim +*> JOBVSL is CHARACTER*1 +*> = 'N': do not compute the left Schur vectors; +*> = 'V': compute the left Schur vectors. +*> \endverbatim +*> +*> \param[in] JOBVSR +*> \verbatim +*> JOBVSR is CHARACTER*1 +*> = 'N': do not compute the right Schur vectors; +*> = 'V': compute the right Schur vectors. +*> \endverbatim +*> +*> \param[in] SORT +*> \verbatim +*> SORT is 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); +*> \endverbatim +*> +*> \param[in] SELCTG +*> \verbatim +*> SELCTG is a LOGICAL FUNCTION of three DOUBLE PRECISION arguments +*> SELCTG must be declared EXTERNAL in the calling subroutine. +*> If SORT = 'N', SELCTG is not referenced. +*> If SORT = 'S', SELCTG is used to select eigenvalues to sort +*> to the top left of the Schur form. +*> An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if +*> SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either +*> one of a complex conjugate pair of eigenvalues is selected, +*> then both complex eigenvalues are selected. +*> +*> Note that in the ill-conditioned case, a selected complex +*> eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j), +*> BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2 +*> in this case. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A, B, VSL, and VSR. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] SDIM +*> \verbatim +*> SDIM is INTEGER +*> If SORT = 'N', SDIM = 0. +*> If SORT = 'S', SDIM = number of eigenvalues (after sorting) +*> for which SELCTG is true. (Complex conjugate pairs for which +*> SELCTG is true for either eigenvalue count as 2.) +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is 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). +*> \endverbatim +*> +*> \param[out] VSL +*> \verbatim +*> VSL is DOUBLE PRECISION array, dimension (LDVSL,N) +*> If JOBVSL = 'V', VSL will contain the left Schur vectors. +*> Not referenced if JOBVSL = 'N'. +*> \endverbatim +*> +*> \param[in] LDVSL +*> \verbatim +*> LDVSL is INTEGER +*> The leading dimension of the matrix VSL. LDVSL >=1, and +*> if JOBVSL = 'V', LDVSL >= N. +*> \endverbatim +*> +*> \param[out] VSR +*> \verbatim +*> VSR is DOUBLE PRECISION array, dimension (LDVSR,N) +*> If JOBVSR = 'V', VSR will contain the right Schur vectors. +*> Not referenced if JOBVSR = 'N'. +*> \endverbatim +*> +*> \param[in] LDVSR +*> \verbatim +*> LDVSR is INTEGER +*> The leading dimension of the matrix VSR. LDVSR >= 1, and +*> if JOBVSR = 'V', LDVSR >= N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If N = 0, LWORK >= 1, else LWORK >= 8*N+16. +*> For good performance , LWORK must generally be larger. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] BWORK +*> \verbatim +*> BWORK is LOGICAL array, dimension (N) +*> Not referenced if SORT = 'N'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> = 1,...,N: +*> The QZ iteration failed. (A,B) are not in Schur +*> form, but ALPHAR(j), ALPHAI(j), and BETA(j) should +*> be correct for j=INFO+1,...,N. +*> > N: =N+1: other than QZ iteration failed in DHGEQZ. +*> =N+2: after reordering, roundoff changed values of +*> some complex eigenvalues so that leading +*> eigenvalues in the Generalized Schur form no +*> longer satisfy SELCTG=.TRUE. This could also +*> be caused due to scaling. +*> =N+3: reordering failed in DTGSEN. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEeigen +* +* ===================================================================== + SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, + $ SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, + $ LDVSR, WORK, LWORK, BWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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 SELCTG + EXTERNAL SELCTG +* .. +* +* ===================================================================== +* +* .. 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.) +* + IF( INFO.EQ.0 ) THEN + IF( N.GT.0 )THEN + MINWRK = MAX( 8*N, 6*N + 16 ) + MAXWRK = MINWRK - N + + $ N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) + MAXWRK = MAX( MAXWRK, MINWRK - N + + $ N*ILAENV( 1, 'DORMQR', ' ', N, 1, N, -1 ) ) + IF( ILVSL ) THEN + MAXWRK = MAX( MAXWRK, MINWRK - N + + $ N*ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) ) + END IF + ELSE + MINWRK = 1 + MAXWRK = 1 + END IF + WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -19 + END IF +* + 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 ) + IF( IROWS.GT.1 ) THEN + CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, + $ VSL( ILO+1, ILO ), LDVSL ) + END IF + 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 SELCTGing +* + 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 ) = SELCTG( 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 = SELCTG( 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/math/lapack/src/main/fortran/dgges3.f b/math/lapack/src/main/fortran/dgges3.f new file mode 100644 index 0000000000..41d2ea0ea2 --- /dev/null +++ b/math/lapack/src/main/fortran/dgges3.f @@ -0,0 +1,674 @@ +*> \brief DGGES3 computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices (blocked algorithm) +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGES3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGES3( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, +* SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, +* LDVSR, WORK, LWORK, BWORK, INFO ) +* +* .. 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 SELCTG +* EXTERNAL SELCTG +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGGES3 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. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVSL +*> \verbatim +*> JOBVSL is CHARACTER*1 +*> = 'N': do not compute the left Schur vectors; +*> = 'V': compute the left Schur vectors. +*> \endverbatim +*> +*> \param[in] JOBVSR +*> \verbatim +*> JOBVSR is CHARACTER*1 +*> = 'N': do not compute the right Schur vectors; +*> = 'V': compute the right Schur vectors. +*> \endverbatim +*> +*> \param[in] SORT +*> \verbatim +*> SORT is 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); +*> \endverbatim +*> +*> \param[in] SELCTG +*> \verbatim +*> SELCTG is a LOGICAL FUNCTION of three DOUBLE PRECISION arguments +*> SELCTG must be declared EXTERNAL in the calling subroutine. +*> If SORT = 'N', SELCTG is not referenced. +*> If SORT = 'S', SELCTG is used to select eigenvalues to sort +*> to the top left of the Schur form. +*> An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if +*> SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either +*> one of a complex conjugate pair of eigenvalues is selected, +*> then both complex eigenvalues are selected. +*> +*> Note that in the ill-conditioned case, a selected complex +*> eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j), +*> BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2 +*> in this case. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A, B, VSL, and VSR. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] SDIM +*> \verbatim +*> SDIM is INTEGER +*> If SORT = 'N', SDIM = 0. +*> If SORT = 'S', SDIM = number of eigenvalues (after sorting) +*> for which SELCTG is true. (Complex conjugate pairs for which +*> SELCTG is true for either eigenvalue count as 2.) +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is 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). +*> \endverbatim +*> +*> \param[out] VSL +*> \verbatim +*> VSL is DOUBLE PRECISION array, dimension (LDVSL,N) +*> If JOBVSL = 'V', VSL will contain the left Schur vectors. +*> Not referenced if JOBVSL = 'N'. +*> \endverbatim +*> +*> \param[in] LDVSL +*> \verbatim +*> LDVSL is INTEGER +*> The leading dimension of the matrix VSL. LDVSL >=1, and +*> if JOBVSL = 'V', LDVSL >= N. +*> \endverbatim +*> +*> \param[out] VSR +*> \verbatim +*> VSR is DOUBLE PRECISION array, dimension (LDVSR,N) +*> If JOBVSR = 'V', VSR will contain the right Schur vectors. +*> Not referenced if JOBVSR = 'N'. +*> \endverbatim +*> +*> \param[in] LDVSR +*> \verbatim +*> LDVSR is INTEGER +*> The leading dimension of the matrix VSR. LDVSR >= 1, and +*> if JOBVSR = 'V', LDVSR >= N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] BWORK +*> \verbatim +*> BWORK is LOGICAL array, dimension (N) +*> Not referenced if SORT = 'N'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> = 1,...,N: +*> The QZ iteration failed. (A,B) are not in Schur +*> form, but ALPHAR(j), ALPHAI(j), and BETA(j) should +*> be correct for j=INFO+1,...,N. +*> > N: =N+1: other than QZ iteration failed in DHGEQZ. +*> =N+2: after reordering, roundoff changed values of +*> some complex eigenvalues so that leading +*> eigenvalues in the Generalized Schur form no +*> longer satisfy SELCTG=.TRUE. This could also +*> be caused due to scaling. +*> =N+3: reordering failed in DTGSEN. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date January 2015 +* +*> \ingroup doubleGEeigen +* +* ===================================================================== + SUBROUTINE DGGES3( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, + $ LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, + $ VSR, LDVSR, WORK, LWORK, BWORK, INFO ) +* +* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* +* .. 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 SELCTG + EXTERNAL SELCTG +* .. +* +* ===================================================================== +* +* .. 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, LWKOPT + 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, DGGHD3, DHGEQZ, DLABAD, + $ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGSEN, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, 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 + ELSE IF( LWORK.LT.6*N+16 .AND. .NOT.LQUERY ) THEN + INFO = -19 + END IF +* +* Compute workspace +* + IF( INFO.EQ.0 ) THEN + CALL DGEQRF( N, N, B, LDB, WORK, WORK, -1, IERR ) + LWKOPT = MAX( 6*N+16, 3*N+INT( WORK ( 1 ) ) ) + CALL DORMQR( 'L', 'T', N, N, N, B, LDB, WORK, A, LDA, WORK, + $ -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) + IF( ILVSL ) THEN + CALL DORGQR( N, N, N, VSL, LDVSL, WORK, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) + END IF + CALL DGGHD3( JOBVSL, JOBVSR, N, 1, N, A, LDA, B, LDB, VSL, + $ LDVSL, VSR, LDVSR, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) + CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, 1, N, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, + $ WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 2*N+INT( WORK ( 1 ) ) ) + IF( WANTST ) THEN + CALL DTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, + $ SDIM, PVSL, PVSR, DIF, WORK, -1, IDUM, 1, + $ IERR ) + LWKOPT = MAX( LWKOPT, 2*N+INT( WORK ( 1 ) ) ) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGES3 ', -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 +* + 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) +* + 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 +* + 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 +* + IF( ILVSL ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL ) + IF( IROWS.GT.1 ) THEN + CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, + $ VSL( ILO+1, ILO ), LDVSL ) + END IF + 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 +* + CALL DGGHD3( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, + $ LDVSL, VSR, LDVSR, WORK( IWRK ), LWORK+1-IWRK, + $ IERR ) +* +* Perform QZ algorithm, computing Schur vectors if desired +* + 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 +* + SDIM = 0 + IF( WANTST ) THEN +* +* Undo scaling on eigenvalues before SELCTGing +* + 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 ) = SELCTG( 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 +* + 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 = SELCTG( 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 ) = LWKOPT +* + RETURN +* +* End of DGGES3 +* + END diff --git a/math/lapack/src/main/fortran/dggesx.f b/math/lapack/src/main/fortran/dggesx.f new file mode 100644 index 0000000000..f316c7fc2e --- /dev/null +++ b/math/lapack/src/main/fortran/dggesx.f @@ -0,0 +1,820 @@ +*> \brief DGGESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGESX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, +* B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, +* VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, +* LIWORK, BWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBVSL, JOBVSR, SENSE, SORT +* INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N, +* $ SDIM +* .. +* .. Array Arguments .. +* LOGICAL BWORK( * ) +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), +* $ B( LDB, * ), BETA( * ), RCONDE( 2 ), +* $ RCONDV( 2 ), VSL( LDVSL, * ), VSR( LDVSR, * ), +* $ WORK( * ) +* .. +* .. Function Arguments .. +* LOGICAL SELCTG +* EXTERNAL SELCTG +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGGESX computes for a pair of N-by-N real nonsymmetric matrices +*> (A,B), the generalized eigenvalues, the real Schur form (S,T), and, +*> optionally, the left and/or right matrices of Schur vectors (VSL and +*> VSR). This gives the generalized Schur factorization +*> +*> (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T ) +*> +*> Optionally, it also orders the eigenvalues so that a selected cluster +*> of eigenvalues appears in the leading diagonal blocks of the upper +*> quasi-triangular matrix S and the upper triangular matrix T; computes +*> a reciprocal condition number for the average of the selected +*> eigenvalues (RCONDE); and computes a reciprocal condition number for +*> the right and left deflating subspaces corresponding to the selected +*> eigenvalues (RCONDV). The leading columns of VSL and VSR then form +*> an orthonormal basis for the corresponding left and right eigenspaces +*> (deflating subspaces). +*> +*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w +*> or a ratio alpha/beta = w, such that A - w*B is singular. It is +*> usually represented as the pair (alpha,beta), as there is a +*> reasonable interpretation for beta=0 or for both being zero. +*> +*> A pair of matrices (S,T) is in generalized real Schur form if T is +*> upper triangular with non-negative diagonal and S is block upper +*> triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond +*> to real generalized eigenvalues, while 2-by-2 blocks of S will be +*> "standardized" by making the corresponding elements of T have the +*> form: +*> [ a 0 ] +*> [ 0 b ] +*> +*> and the pair of corresponding 2-by-2 blocks in S and T will have a +*> complex conjugate pair of generalized eigenvalues. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVSL +*> \verbatim +*> JOBVSL is CHARACTER*1 +*> = 'N': do not compute the left Schur vectors; +*> = 'V': compute the left Schur vectors. +*> \endverbatim +*> +*> \param[in] JOBVSR +*> \verbatim +*> JOBVSR is CHARACTER*1 +*> = 'N': do not compute the right Schur vectors; +*> = 'V': compute the right Schur vectors. +*> \endverbatim +*> +*> \param[in] SORT +*> \verbatim +*> SORT is 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). +*> \endverbatim +*> +*> \param[in] SELCTG +*> \verbatim +*> SELCTG is procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments +*> SELCTG must be declared EXTERNAL in the calling subroutine. +*> If SORT = 'N', SELCTG is not referenced. +*> If SORT = 'S', SELCTG is used to select eigenvalues to sort +*> to the top left of the Schur form. +*> An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if +*> SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either +*> one of a complex conjugate pair of eigenvalues is selected, +*> then both complex eigenvalues are selected. +*> Note that a selected complex eigenvalue may no longer satisfy +*> SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering, +*> since ordering may change the value of complex eigenvalues +*> (especially if the eigenvalue is ill-conditioned), in this +*> case INFO is set to N+3. +*> \endverbatim +*> +*> \param[in] SENSE +*> \verbatim +*> SENSE is CHARACTER*1 +*> Determines which reciprocal condition numbers are computed. +*> = 'N' : None are computed; +*> = 'E' : Computed for average of selected eigenvalues only; +*> = 'V' : Computed for selected deflating subspaces only; +*> = 'B' : Computed for both. +*> If SENSE = 'E', 'V', or 'B', SORT must equal 'S'. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A, B, VSL, and VSR. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] SDIM +*> \verbatim +*> SDIM is INTEGER +*> If SORT = 'N', SDIM = 0. +*> If SORT = 'S', SDIM = number of eigenvalues (after sorting) +*> for which SELCTG is true. (Complex conjugate pairs for which +*> SELCTG is true for either eigenvalue count as 2.) +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is 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). +*> \endverbatim +*> +*> \param[out] VSL +*> \verbatim +*> VSL is DOUBLE PRECISION array, dimension (LDVSL,N) +*> If JOBVSL = 'V', VSL will contain the left Schur vectors. +*> Not referenced if JOBVSL = 'N'. +*> \endverbatim +*> +*> \param[in] LDVSL +*> \verbatim +*> LDVSL is INTEGER +*> The leading dimension of the matrix VSL. LDVSL >=1, and +*> if JOBVSL = 'V', LDVSL >= N. +*> \endverbatim +*> +*> \param[out] VSR +*> \verbatim +*> VSR is DOUBLE PRECISION array, dimension (LDVSR,N) +*> If JOBVSR = 'V', VSR will contain the right Schur vectors. +*> Not referenced if JOBVSR = 'N'. +*> \endverbatim +*> +*> \param[in] LDVSR +*> \verbatim +*> LDVSR is INTEGER +*> The leading dimension of the matrix VSR. LDVSR >= 1, and +*> if JOBVSR = 'V', LDVSR >= N. +*> \endverbatim +*> +*> \param[out] RCONDE +*> \verbatim +*> RCONDE is DOUBLE PRECISION array, dimension ( 2 ) +*> If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the +*> reciprocal condition numbers for the average of the selected +*> eigenvalues. +*> Not referenced if SENSE = 'N' or 'V'. +*> \endverbatim +*> +*> \param[out] RCONDV +*> \verbatim +*> RCONDV is DOUBLE PRECISION array, dimension ( 2 ) +*> If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the +*> reciprocal condition numbers for the selected deflating +*> subspaces. +*> Not referenced if SENSE = 'N' or 'E'. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B', +*> LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else +*> LWORK >= max( 8*N, 6*N+16 ). +*> Note that 2*SDIM*(N-SDIM) <= N*N/2. +*> Note also that an error is only returned if +*> LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B' +*> this may not be large enough. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the bound on the optimal size of the WORK +*> array and the minimum size of the IWORK array, returns these +*> values as the first entries of the WORK and IWORK arrays, and +*> no error message related to LWORK or LIWORK is issued by +*> XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise +*> LIWORK >= N+6. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the bound on the optimal size of the +*> WORK array and the minimum size of the IWORK array, returns +*> these values as the first entries of the WORK and IWORK +*> arrays, and no error message related to LWORK or LIWORK is +*> issued by XERBLA. +*> \endverbatim +*> +*> \param[out] BWORK +*> \verbatim +*> BWORK is LOGICAL array, dimension (N) +*> Not referenced if SORT = 'N'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> = 1,...,N: +*> The QZ iteration failed. (A,B) are not in Schur +*> form, but ALPHAR(j), ALPHAI(j), and BETA(j) should +*> be correct for j=INFO+1,...,N. +*> > N: =N+1: other than QZ iteration failed in DHGEQZ +*> =N+2: after reordering, roundoff changed values of +*> some complex eigenvalues so that leading +*> eigenvalues in the Generalized Schur form no +*> longer satisfy SELCTG=.TRUE. This could also +*> be caused due to scaling. +*> =N+3: reordering failed in DTGSEN. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> An approximate (asymptotic) bound on the average absolute error of +*> the selected eigenvalues is +*> +*> EPS * norm((A, B)) / RCONDE( 1 ). +*> +*> An approximate (asymptotic) bound on the maximum angular error in +*> the computed deflating subspaces is +*> +*> EPS * norm((A, B)) / RCONDV( 2 ). +*> +*> See LAPACK User's Guide, section 4.11 for more information. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, + $ B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, + $ VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, + $ LIWORK, BWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBVSL, JOBVSR, SENSE, SORT + INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N, + $ SDIM +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), + $ B( LDB, * ), BETA( * ), RCONDE( 2 ), + $ RCONDV( 2 ), VSL( LDVSL, * ), VSR( LDVSR, * ), + $ WORK( * ) +* .. +* .. Function Arguments .. + LOGICAL SELCTG + EXTERNAL SELCTG +* .. +* +* ===================================================================== +* +* .. 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, WANTSB, WANTSE, WANTSN, WANTST, + $ WANTSV + INTEGER I, ICOLS, IERR, IHI, IJOB, IJOBVL, IJOBVR, + $ ILEFT, ILO, IP, IRIGHT, IROWS, ITAU, IWRK, + $ LIWMIN, LWRK, MAXWRK, MINWRK + DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PL, + $ PR, SAFMAX, SAFMIN, SMLNUM +* .. +* .. Local Arrays .. + 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' ) + 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( WANTSN ) THEN + IJOB = 0 + ELSE IF( WANTSE ) THEN + IJOB = 1 + ELSE IF( WANTSV ) THEN + IJOB = 2 + ELSE IF( WANTSB ) THEN + IJOB = 4 + END IF +* +* Test the input arguments +* + INFO = 0 + 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( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR. + $ ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN + INFO = -16 + ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN + INFO = -18 + 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 + IF( N.GT.0) THEN + MINWRK = MAX( 8*N, 6*N + 16 ) + MAXWRK = MINWRK - N + + $ N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) + MAXWRK = MAX( MAXWRK, MINWRK - N + + $ N*ILAENV( 1, 'DORMQR', ' ', N, 1, N, -1 ) ) + IF( ILVSL ) THEN + MAXWRK = MAX( MAXWRK, MINWRK - N + + $ N*ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) ) + END IF + LWRK = MAXWRK + IF( IJOB.GE.1 ) + $ LWRK = MAX( LWRK, N*N/2 ) + ELSE + MINWRK = 1 + MAXWRK = 1 + LWRK = 1 + END IF + WORK( 1 ) = LWRK + IF( WANTSN .OR. N.EQ.0 ) THEN + LIWMIN = 1 + ELSE + LIWMIN = N + 6 + END IF + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -22 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -24 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGESX', -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 for permutation parameters) +* + 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 ) + IF( IROWS.GT.1 ) THEN + CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, + $ VSL( ILO+1, ILO ), LDVSL ) + END IF + 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 ) +* + SDIM = 0 +* +* 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 60 + END IF +* +* Sort eigenvalues ALPHA/BETA and compute the reciprocal of +* condition number(s) +* (Workspace: If IJOB >= 1, need MAX( 8*(N+1), 2*SDIM*(N-SDIM) ) +* otherwise, need 8*(N+1) ) +* + IF( WANTST ) THEN +* +* Undo scaling on eigenvalues before SELCTGing +* + 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 ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) + 10 CONTINUE +* +* Reorder eigenvalues, transform Generalized Schur vectors, and +* compute reciprocal condition numbers +* + CALL DTGSEN( IJOB, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, + $ SDIM, PL, PR, DIF, WORK( IWRK ), LWORK-IWRK+1, + $ IWORK, LIWORK, IERR ) +* + IF( IJOB.GE.1 ) + $ MAXWRK = MAX( MAXWRK, 2*SDIM*( N-SDIM ) ) + IF( IERR.EQ.-22 ) THEN +* +* not enough real workspace +* + INFO = -22 + ELSE + IF( IJOB.EQ.1 .OR. IJOB.EQ.4 ) THEN + RCONDE( 1 ) = PL + RCONDE( 2 ) = PR + END IF + IF( IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN + RCONDV( 1 ) = DIF( 1 ) + RCONDV( 2 ) = DIF( 2 ) + END IF + IF( IERR.EQ.1 ) + $ INFO = N + 3 + END IF +* + END IF +* +* Apply 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 50 I = 1, N + CURSL = SELCTG( 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 + 50 CONTINUE +* + END IF +* + 60 CONTINUE +* + WORK( 1 ) = MAXWRK + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of DGGESX +* + END diff --git a/math/lapack/src/main/fortran/dggev.f b/math/lapack/src/main/fortran/dggev.f new file mode 100644 index 0000000000..fa86828247 --- /dev/null +++ b/math/lapack/src/main/fortran/dggev.f @@ -0,0 +1,592 @@ +*> \brief DGGEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, +* BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) +* +* .. 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( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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). +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVL +*> \verbatim +*> JOBVL is CHARACTER*1 +*> = 'N': do not compute the left generalized eigenvectors; +*> = 'V': compute the left generalized eigenvectors. +*> \endverbatim +*> +*> \param[in] JOBVR +*> \verbatim +*> JOBVR is CHARACTER*1 +*> = 'N': do not compute the right generalized eigenvectors; +*> = 'V': compute the right generalized eigenvectors. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A, B, VL, and VR. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the matrix A in the pair (A,B). +*> On exit, A has been overwritten. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB, N) +*> On entry, the matrix B in the pair (A,B). +*> On exit, B has been overwritten. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is 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). +*> \endverbatim +*> +*> \param[out] VL +*> \verbatim +*> VL is 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'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the matrix VL. LDVL >= 1, and +*> if JOBVL = 'V', LDVL >= N. +*> \endverbatim +*> +*> \param[out] VR +*> \verbatim +*> VR is 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'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the matrix VR. LDVR >= 1, and +*> if JOBVR = 'V', LDVR >= N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleGEeigen +* +* ===================================================================== + SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, + $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. 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( * ) +* .. +* +* ===================================================================== +* +* .. 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 +* + 110 CONTINUE +* + 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 +* + WORK( 1 ) = MAXWRK + RETURN +* +* End of DGGEV +* + END diff --git a/math/lapack/src/main/fortran/dggev3.f b/math/lapack/src/main/fortran/dggev3.f new file mode 100644 index 0000000000..43a853dffe --- /dev/null +++ b/math/lapack/src/main/fortran/dggev3.f @@ -0,0 +1,594 @@ +*> \brief DGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices (blocked algorithm) +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGEV3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, +* $ ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, +* $ INFO ) +* +* .. 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( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGGEV3 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). +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVL +*> \verbatim +*> JOBVL is CHARACTER*1 +*> = 'N': do not compute the left generalized eigenvectors; +*> = 'V': compute the left generalized eigenvectors. +*> \endverbatim +*> +*> \param[in] JOBVR +*> \verbatim +*> JOBVR is CHARACTER*1 +*> = 'N': do not compute the right generalized eigenvectors; +*> = 'V': compute the right generalized eigenvectors. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A, B, VL, and VR. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the matrix A in the pair (A,B). +*> On exit, A has been overwritten. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB, N) +*> On entry, the matrix B in the pair (A,B). +*> On exit, B has been overwritten. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is 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). +*> \endverbatim +*> +*> \param[out] VL +*> \verbatim +*> VL is 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'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the matrix VL. LDVL >= 1, and +*> if JOBVL = 'V', LDVL >= N. +*> \endverbatim +*> +*> \param[out] VR +*> \verbatim +*> VR is 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'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the matrix VR. LDVR >= 1, and +*> if JOBVR = 'V', LDVR >= N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> = 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date January 2015 +* +*> \ingroup doubleGEeigen +* +* ===================================================================== + SUBROUTINE DGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, + $ ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, + $ INFO ) +* +* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* +* .. 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( * ) +* .. +* +* ===================================================================== +* +* .. 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, LWKOPT + DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, + $ SMLNUM, TEMP +* .. +* .. Local Arrays .. + LOGICAL LDUMMA( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHD3, DHGEQZ, DLABAD, + $ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, 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 + ELSE IF( LWORK.LT.MAX( 1, 8*N ) .AND. .NOT.LQUERY ) THEN + INFO = -16 + END IF +* +* Compute workspace +* + IF( INFO.EQ.0 ) THEN + CALL DGEQRF( N, N, B, LDB, WORK, WORK, -1, IERR ) + LWKOPT = MAX(1, 8*N, 3*N+INT( WORK( 1 ) ) ) + CALL DORMQR( 'L', 'T', N, N, N, B, LDB, WORK, A, LDA, WORK, -1, + $ IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) + IF( ILVL ) THEN + CALL DORGQR( N, N, N, VL, LDVL, WORK, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) + END IF + IF( ILV ) THEN + CALL DGGHD3( JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, VL, + $ LDVL, VR, LDVR, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) + CALL DHGEQZ( 'S', JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, + $ WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 2*N+INT( WORK ( 1 ) ) ) + ELSE + CALL DGGHD3( 'N', 'N', N, 1, N, A, LDA, B, LDB, VL, LDVL, + $ VR, LDVR, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) + CALL DHGEQZ( 'E', JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, + $ WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 2*N+INT( WORK ( 1 ) ) ) + END IF + + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGEV3 ', -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 +* + 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) +* + 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 +* + 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 +* + 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 +* + IF( ILV ) THEN +* +* Eigenvectors requested -- work on whole matrix. +* + CALL DGGHD3( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL, + $ LDVL, VR, LDVR, WORK( IWRK ), LWORK+1-IWRK, IERR ) + ELSE + CALL DGGHD3( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA, + $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Perform QZ algorithm (Compute eigenvalues, and optionally, the +* Schur forms and Schur vectors) +* + 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 +* + 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 +* + 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 +* + 110 CONTINUE +* + 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 +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of DGGEV3 +* + END diff --git a/math/lapack/src/main/fortran/dggevx.f b/math/lapack/src/main/fortran/dggevx.f new file mode 100644 index 0000000000..1f6962df5d --- /dev/null +++ b/math/lapack/src/main/fortran/dggevx.f @@ -0,0 +1,868 @@ +*> \brief DGGEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, +* ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, +* IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, +* RCONDV, WORK, LWORK, IWORK, BWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER BALANC, JOBVL, JOBVR, SENSE +* INTEGER IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N +* DOUBLE PRECISION ABNRM, BBNRM +* .. +* .. Array Arguments .. +* LOGICAL BWORK( * ) +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), +* $ B( LDB, * ), BETA( * ), LSCALE( * ), +* $ RCONDE( * ), RCONDV( * ), RSCALE( * ), +* $ VL( LDVL, * ), VR( LDVR, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B) +*> the generalized eigenvalues, and optionally, the left and/or right +*> generalized eigenvectors. +*> +*> Optionally also, it computes a balancing transformation to improve +*> the conditioning of the eigenvalues and eigenvectors (ILO, IHI, +*> LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for +*> the eigenvalues (RCONDE), and reciprocal condition numbers for the +*> right eigenvectors (RCONDV). +*> +*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar +*> lambda or a ratio alpha/beta = lambda, such that A - lambda*B is +*> singular. It is usually represented as the pair (alpha,beta), as +*> there is a reasonable interpretation for beta=0, and even for both +*> being zero. +*> +*> The right eigenvector v(j) corresponding to the eigenvalue lambda(j) +*> of (A,B) satisfies +*> +*> A * v(j) = lambda(j) * B * v(j) . +*> +*> The left eigenvector u(j) corresponding to the eigenvalue lambda(j) +*> of (A,B) satisfies +*> +*> u(j)**H * A = lambda(j) * u(j)**H * B. +*> +*> where u(j)**H is the conjugate-transpose of u(j). +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] BALANC +*> \verbatim +*> BALANC is CHARACTER*1 +*> Specifies the balance option to be performed. +*> = 'N': do not diagonally scale or permute; +*> = 'P': permute only; +*> = 'S': scale only; +*> = 'B': both permute and scale. +*> Computed reciprocal condition numbers will be for the +*> matrices after permuting and/or balancing. Permuting does +*> not change condition numbers (in exact arithmetic), but +*> balancing does. +*> \endverbatim +*> +*> \param[in] JOBVL +*> \verbatim +*> JOBVL is CHARACTER*1 +*> = 'N': do not compute the left generalized eigenvectors; +*> = 'V': compute the left generalized eigenvectors. +*> \endverbatim +*> +*> \param[in] JOBVR +*> \verbatim +*> JOBVR is CHARACTER*1 +*> = 'N': do not compute the right generalized eigenvectors; +*> = 'V': compute the right generalized eigenvectors. +*> \endverbatim +*> +*> \param[in] SENSE +*> \verbatim +*> SENSE is CHARACTER*1 +*> Determines which reciprocal condition numbers are computed. +*> = 'N': none are computed; +*> = 'E': computed for eigenvalues only; +*> = 'V': computed for eigenvectors only; +*> = 'B': computed for eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A, B, VL, and VR. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the matrix A in the pair (A,B). +*> On exit, A has been overwritten. If JOBVL='V' or JOBVR='V' +*> or both, then A contains the first part of the real Schur +*> form of the "balanced" versions of the input A and B. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB, N) +*> On entry, the matrix B in the pair (A,B). +*> On exit, B has been overwritten. If JOBVL='V' or JOBVR='V' +*> or both, then B contains the second part of the real Schur +*> form of the "balanced" versions of the input A and B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is 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). +*> \endverbatim +*> +*> \param[out] VL +*> \verbatim +*> VL is DOUBLE PRECISION array, dimension (LDVL,N) +*> If JOBVL = 'V', the left eigenvectors u(j) are stored one +*> after another in the columns of VL, in the same order as +*> their eigenvalues. If the j-th eigenvalue is real, then +*> u(j) = VL(:,j), the j-th column of VL. If the j-th and +*> (j+1)-th eigenvalues form a complex conjugate pair, then +*> u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). +*> Each eigenvector will be scaled so the largest component have +*> abs(real part) + abs(imag. part) = 1. +*> Not referenced if JOBVL = 'N'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the matrix VL. LDVL >= 1, and +*> if JOBVL = 'V', LDVL >= N. +*> \endverbatim +*> +*> \param[out] VR +*> \verbatim +*> VR is DOUBLE PRECISION array, dimension (LDVR,N) +*> If JOBVR = 'V', the right eigenvectors v(j) are stored one +*> after another in the columns of VR, in the same order as +*> their eigenvalues. If the j-th eigenvalue is real, then +*> v(j) = VR(:,j), the j-th column of VR. If the j-th and +*> (j+1)-th eigenvalues form a complex conjugate pair, then +*> v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). +*> Each eigenvector will be scaled so the largest component have +*> abs(real part) + abs(imag. part) = 1. +*> Not referenced if JOBVR = 'N'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the matrix VR. LDVR >= 1, and +*> if JOBVR = 'V', LDVR >= N. +*> \endverbatim +*> +*> \param[out] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[out] IHI +*> \verbatim +*> IHI is INTEGER +*> ILO and IHI are integer values such that on exit +*> A(i,j) = 0 and B(i,j) = 0 if i > j and +*> j = 1,...,ILO-1 or i = IHI+1,...,N. +*> If BALANC = 'N' or 'S', ILO = 1 and IHI = N. +*> \endverbatim +*> +*> \param[out] LSCALE +*> \verbatim +*> LSCALE is DOUBLE PRECISION array, dimension (N) +*> Details of the permutations and scaling factors applied +*> to the left side of A and B. If PL(j) is the index of the +*> row interchanged with row j, and DL(j) is the scaling +*> factor applied to row j, then +*> LSCALE(j) = PL(j) for j = 1,...,ILO-1 +*> = DL(j) for j = ILO,...,IHI +*> = PL(j) for j = IHI+1,...,N. +*> The order in which the interchanges are made is N to IHI+1, +*> then 1 to ILO-1. +*> \endverbatim +*> +*> \param[out] RSCALE +*> \verbatim +*> RSCALE is DOUBLE PRECISION array, dimension (N) +*> Details of the permutations and scaling factors applied +*> to the right side of A and B. If PR(j) is the index of the +*> column interchanged with column j, and DR(j) is the scaling +*> factor applied to column j, then +*> RSCALE(j) = PR(j) for j = 1,...,ILO-1 +*> = DR(j) for j = ILO,...,IHI +*> = PR(j) for j = IHI+1,...,N +*> The order in which the interchanges are made is N to IHI+1, +*> then 1 to ILO-1. +*> \endverbatim +*> +*> \param[out] ABNRM +*> \verbatim +*> ABNRM is DOUBLE PRECISION +*> The one-norm of the balanced matrix A. +*> \endverbatim +*> +*> \param[out] BBNRM +*> \verbatim +*> BBNRM is DOUBLE PRECISION +*> The one-norm of the balanced matrix B. +*> \endverbatim +*> +*> \param[out] RCONDE +*> \verbatim +*> RCONDE is DOUBLE PRECISION array, dimension (N) +*> If SENSE = 'E' or 'B', the reciprocal condition numbers of +*> the eigenvalues, stored in consecutive elements of the array. +*> For a complex conjugate pair of eigenvalues two consecutive +*> elements of RCONDE are set to the same value. Thus RCONDE(j), +*> RCONDV(j), and the j-th columns of VL and VR all correspond +*> to the j-th eigenpair. +*> If SENSE = 'N or 'V', RCONDE is not referenced. +*> \endverbatim +*> +*> \param[out] RCONDV +*> \verbatim +*> RCONDV is DOUBLE PRECISION array, dimension (N) +*> If SENSE = 'V' or 'B', the estimated reciprocal condition +*> numbers of the eigenvectors, stored in consecutive elements +*> of the array. For a complex eigenvector two consecutive +*> elements of RCONDV are set to the same value. If the +*> eigenvalues cannot be reordered to compute RCONDV(j), +*> RCONDV(j) is set to 0; this can only occur when the true +*> value would be very small anyway. +*> If SENSE = 'N' or 'E', RCONDV is not referenced. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= max(1,2*N). +*> If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V', +*> LWORK >= max(1,6*N). +*> If SENSE = 'E' or 'B', LWORK >= max(1,10*N). +*> If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N+6) +*> If SENSE = 'E', IWORK is not referenced. +*> \endverbatim +*> +*> \param[out] BWORK +*> \verbatim +*> BWORK is LOGICAL array, dimension (N) +*> If SENSE = 'N', BWORK is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleGEeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Balancing a matrix pair (A,B) includes, first, permuting rows and +*> columns to isolate eigenvalues, second, applying diagonal similarity +*> transformation to the rows and columns to make the rows and columns +*> as close in norm as possible. The computed reciprocal condition +*> numbers correspond to the balanced matrix. Permuting rows and columns +*> will not change the condition numbers (in exact arithmetic) but +*> diagonal scaling will. For further explanation of balancing, see +*> section 4.11.1.2 of LAPACK Users' Guide. +*> +*> An approximate error bound on the chordal distance between the i-th +*> computed generalized eigenvalue w and the corresponding exact +*> eigenvalue lambda is +*> +*> chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I) +*> +*> An approximate error bound for the angle between the i-th computed +*> eigenvector VL(i) or VR(i) is given by +*> +*> EPS * norm(ABNRM, BBNRM) / DIF(i). +*> +*> For further explanation of the reciprocal condition numbers RCONDE +*> and RCONDV, see section 4.11 of LAPACK User's Guide. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, + $ IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, + $ RCONDV, WORK, LWORK, IWORK, BWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER BALANC, JOBVL, JOBVR, SENSE + INTEGER IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N + DOUBLE PRECISION ABNRM, BBNRM +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), + $ B( LDB, * ), BETA( * ), LSCALE( * ), + $ RCONDE( * ), RCONDV( * ), RSCALE( * ), + $ VL( LDVL, * ), VR( LDVR, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, NOSCL, + $ PAIR, WANTSB, WANTSE, WANTSN, WANTSV + CHARACTER CHTEMP + INTEGER I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS, + $ ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK, + $ MINWRK, MM + 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, + $ DTGSNA, 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 +* + NOSCL = LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'P' ) + WANTSN = LSAME( SENSE, 'N' ) + WANTSE = LSAME( SENSE, 'E' ) + WANTSV = LSAME( SENSE, 'V' ) + WANTSB = LSAME( SENSE, 'B' ) +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, + $ 'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) + $ THEN + INFO = -1 + ELSE IF( IJOBVL.LE.0 ) THEN + INFO = -2 + ELSE IF( IJOBVR.LE.0 ) THEN + INFO = -3 + ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSB .OR. WANTSV ) ) + $ THEN + INFO = -4 + 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( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN + INFO = -14 + ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.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. The workspace 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 + IF( NOSCL .AND. .NOT.ILV ) THEN + MINWRK = 2*N + ELSE + MINWRK = 6*N + END IF + IF( WANTSE .OR. WANTSB ) THEN + MINWRK = 10*N + END IF + IF( WANTSV .OR. WANTSB ) THEN + MINWRK = MAX( MINWRK, 2*N*( N + 4 ) + 16 ) + END IF + MAXWRK = MINWRK + MAXWRK = MAX( MAXWRK, + $ N + N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) ) + MAXWRK = MAX( MAXWRK, + $ N + N*ILAENV( 1, 'DORMQR', ' ', N, 1, N, 0 ) ) + IF( ILVL ) THEN + MAXWRK = MAX( MAXWRK, N + + $ N*ILAENV( 1, 'DORGQR', ' ', N, 1, N, 0 ) ) + END IF + END IF + WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -26 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGEVX', -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 and/or balance the matrix pair (A,B) +* (Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise) +* + CALL DGGBAL( BALANC, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, + $ WORK, IERR ) +* +* Compute ABNRM and BBNRM +* + ABNRM = DLANGE( '1', N, N, A, LDA, WORK( 1 ) ) + IF( ILASCL ) THEN + WORK( 1 ) = ABNRM + CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, 1, 1, WORK( 1 ), 1, + $ IERR ) + ABNRM = WORK( 1 ) + END IF +* + BBNRM = DLANGE( '1', N, N, B, LDB, WORK( 1 ) ) + IF( ILBSCL ) THEN + WORK( 1 ) = BBNRM + CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, 1, 1, WORK( 1 ), 1, + $ IERR ) + BBNRM = WORK( 1 ) + END IF +* +* Reduce B to triangular form (QR decomposition of B) +* (Workspace: need N, prefer N*NB ) +* + IROWS = IHI + 1 - ILO + IF( ILV .OR. .NOT.WANTSN ) THEN + ICOLS = N + 1 - ILO + ELSE + ICOLS = IROWS + END IF + ITAU = 1 + IWRK = ITAU + IROWS + CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) +* +* Apply the orthogonal transformation to 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 and/or VR +* (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 +* + IF( ILVR ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR ) +* +* Reduce to generalized Hessenberg form +* (Workspace: none needed) +* + IF( ILV .OR. .NOT.WANTSN ) 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) +* + IF( ILV .OR. .NOT.WANTSN ) 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, + $ LWORK, 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 130 + END IF +* +* Compute Eigenvectors and estimate condition numbers if desired +* (Workspace: DTGEVC: need 6*N +* DTGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B', +* need N otherwise ) +* + IF( ILV .OR. .NOT.WANTSN ) THEN + 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, IERR ) + IF( IERR.NE.0 ) THEN + INFO = N + 2 + GO TO 130 + END IF + END IF +* + IF( .NOT.WANTSN ) THEN +* +* compute eigenvectors (DTGEVC) and estimate condition +* numbers (DTGSNA). Note that the definition of the condition +* number is not invariant under transformation (u,v) to +* (Q*u, Z*v), where (u,v) are eigenvectors of the generalized +* Schur form (S,T), Q and Z are orthogonal matrices. In order +* to avoid using extra 2*N*N workspace, we have to recalculate +* eigenvectors and estimate one condition numbers at a time. +* + PAIR = .FALSE. + DO 20 I = 1, N +* + IF( PAIR ) THEN + PAIR = .FALSE. + GO TO 20 + END IF + MM = 1 + IF( I.LT.N ) THEN + IF( A( I+1, I ).NE.ZERO ) THEN + PAIR = .TRUE. + MM = 2 + END IF + END IF +* + DO 10 J = 1, N + BWORK( J ) = .FALSE. + 10 CONTINUE + IF( MM.EQ.1 ) THEN + BWORK( I ) = .TRUE. + ELSE IF( MM.EQ.2 ) THEN + BWORK( I ) = .TRUE. + BWORK( I+1 ) = .TRUE. + END IF +* + IWRK = MM*N + 1 + IWRK1 = IWRK + MM*N +* +* Compute a pair of left and right eigenvectors. +* (compute workspace: need up to 4*N + 6*N) +* + IF( WANTSE .OR. WANTSB ) THEN + CALL DTGEVC( 'B', 'S', BWORK, N, A, LDA, B, LDB, + $ WORK( 1 ), N, WORK( IWRK ), N, MM, M, + $ WORK( IWRK1 ), IERR ) + IF( IERR.NE.0 ) THEN + INFO = N + 2 + GO TO 130 + END IF + END IF +* + CALL DTGSNA( SENSE, 'S', BWORK, N, A, LDA, B, LDB, + $ WORK( 1 ), N, WORK( IWRK ), N, RCONDE( I ), + $ RCONDV( I ), MM, M, WORK( IWRK1 ), + $ LWORK-IWRK1+1, IWORK, IERR ) +* + 20 CONTINUE + END IF + END IF +* +* Undo balancing on VL and VR and normalization +* (Workspace: none needed) +* + IF( ILVL ) THEN + CALL DGGBAK( BALANC, 'L', N, ILO, IHI, LSCALE, RSCALE, N, VL, + $ LDVL, IERR ) +* + DO 70 JC = 1, N + IF( ALPHAI( JC ).LT.ZERO ) + $ GO TO 70 + TEMP = ZERO + IF( ALPHAI( JC ).EQ.ZERO ) THEN + DO 30 JR = 1, N + TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) ) + 30 CONTINUE + ELSE + DO 40 JR = 1, N + TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+ + $ ABS( VL( JR, JC+1 ) ) ) + 40 CONTINUE + END IF + IF( TEMP.LT.SMLNUM ) + $ GO TO 70 + TEMP = ONE / TEMP + IF( ALPHAI( JC ).EQ.ZERO ) THEN + DO 50 JR = 1, N + VL( JR, JC ) = VL( JR, JC )*TEMP + 50 CONTINUE + ELSE + DO 60 JR = 1, N + VL( JR, JC ) = VL( JR, JC )*TEMP + VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP + 60 CONTINUE + END IF + 70 CONTINUE + END IF + IF( ILVR ) THEN + CALL DGGBAK( BALANC, 'R', N, ILO, IHI, LSCALE, RSCALE, N, VR, + $ LDVR, IERR ) + DO 120 JC = 1, N + IF( ALPHAI( JC ).LT.ZERO ) + $ GO TO 120 + TEMP = ZERO + IF( ALPHAI( JC ).EQ.ZERO ) THEN + DO 80 JR = 1, N + TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) ) + 80 CONTINUE + ELSE + DO 90 JR = 1, N + TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+ + $ ABS( VR( JR, JC+1 ) ) ) + 90 CONTINUE + END IF + IF( TEMP.LT.SMLNUM ) + $ GO TO 120 + TEMP = ONE / TEMP + IF( ALPHAI( JC ).EQ.ZERO ) THEN + DO 100 JR = 1, N + VR( JR, JC ) = VR( JR, JC )*TEMP + 100 CONTINUE + ELSE + DO 110 JR = 1, N + VR( JR, JC ) = VR( JR, JC )*TEMP + VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP + 110 CONTINUE + END IF + 120 CONTINUE + END IF +* +* Undo scaling if necessary +* + 130 CONTINUE +* + 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 +* + WORK( 1 ) = MAXWRK + RETURN +* +* End of DGGEVX +* + END diff --git a/math/lapack/src/main/fortran/dggglm.f b/math/lapack/src/main/fortran/dggglm.f new file mode 100644 index 0000000000..2e92912e0d --- /dev/null +++ b/math/lapack/src/main/fortran/dggglm.f @@ -0,0 +1,348 @@ +*> \brief \b DGGGLM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGGLM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LWORK, M, N, P +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( * ), WORK( * ), +* $ X( * ), Y( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGGGLM solves a general Gauss-Markov linear model (GLM) problem: +*> +*> minimize || y ||_2 subject to d = A*x + B*y +*> x +*> +*> where A is an N-by-M matrix, B is an N-by-P matrix, and d is a +*> given N-vector. It is assumed that M <= N <= M+P, and +*> +*> rank(A) = M and rank( A B ) = N. +*> +*> Under these assumptions, the constrained equation is always +*> consistent, and there is a unique solution x and a minimal 2-norm +*> solution y, which is obtained using a generalized QR factorization +*> of the matrices (A, B) given by +*> +*> A = Q*(R), B = Q*T*Z. +*> (0) +*> +*> In particular, if matrix B is square nonsingular, then the problem +*> GLM is equivalent to the following weighted linear least squares +*> problem +*> +*> minimize || inv(B)*(d-A*x) ||_2 +*> x +*> +*> where inv(B) denotes the inverse of B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of columns of the matrix A. 0 <= M <= N. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of columns of the matrix B. P >= N-M. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,M) +*> On entry, the N-by-M matrix A. +*> On exit, the upper triangular part of the array A contains +*> the M-by-M upper triangular matrix R. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,P) +*> On entry, the N-by-P matrix B. +*> On exit, if N <= P, the upper triangle of the subarray +*> B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; +*> if N > P, the elements on and above the (N-P)th subdiagonal +*> contain the N-by-P upper trapezoidal matrix T. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, D is the left hand side of the GLM equation. +*> On exit, D is destroyed. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (M) +*> \endverbatim +*> +*> \param[out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension (P) +*> +*> On exit, X and Y are the solutions of the GLM problem. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= max(1,N+M+P). +*> For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB, +*> where NB is an upper bound for the optimal blocksizes for +*> DGEQRF, SGERQF, DORMQR and SORMRQ. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> = 1: the upper triangular factor R associated with A in the +*> generalized QR factorization of the pair (A, B) is +*> singular, so that rank(A) < M; the least squares +*> solution could not be computed. +*> = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal +*> factor T associated with B in the generalized QR +*> factorization of the pair (A, B) is singular, so that +*> rank( A B ) < N; the least squares solution could not +*> be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHEReigen +* +* ===================================================================== + SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, + $ INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LWORK, M, N, P +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( * ), WORK( * ), + $ X( * ), Y( * ) +* .. +* +* =================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, LOPT, LWKMIN, LWKOPT, NB, NB1, NB2, NB3, + $ NB4, NP +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DGGQRF, DORMQR, DORMRQ, DTRTRS, + $ XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + NP = MIN( N, P ) + LQUERY = ( LWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 .OR. M.GT.N ) THEN + INFO = -2 + ELSE IF( P.LT.0 .OR. P.LT.N-M ) 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 +* +* Calculate workspace +* + IF( INFO.EQ.0) THEN + IF( N.EQ.0 ) THEN + LWKMIN = 1 + LWKOPT = 1 + ELSE + NB1 = ILAENV( 1, 'DGEQRF', ' ', N, M, -1, -1 ) + NB2 = ILAENV( 1, 'DGERQF', ' ', N, M, -1, -1 ) + NB3 = ILAENV( 1, 'DORMQR', ' ', N, M, P, -1 ) + NB4 = ILAENV( 1, 'DORMRQ', ' ', N, M, P, -1 ) + NB = MAX( NB1, NB2, NB3, NB4 ) + LWKMIN = M + N + P + LWKOPT = M + NP + MAX( N, P )*NB + 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( 'DGGGLM', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Compute the GQR factorization of matrices A and B: +* +* Q**T*A = ( R11 ) M, Q**T*B*Z**T = ( T11 T12 ) M +* ( 0 ) N-M ( 0 T22 ) N-M +* M M+P-N N-M +* +* where R11 and T22 are upper triangular, and Q and Z are +* orthogonal. +* + CALL DGGQRF( N, M, P, A, LDA, WORK, B, LDB, WORK( M+1 ), + $ WORK( M+NP+1 ), LWORK-M-NP, INFO ) + LOPT = WORK( M+NP+1 ) +* +* Update left-hand-side vector d = Q**T*d = ( d1 ) M +* ( d2 ) N-M +* + CALL DORMQR( 'Left', 'Transpose', N, 1, M, A, LDA, WORK, D, + $ MAX( 1, N ), WORK( M+NP+1 ), LWORK-M-NP, INFO ) + LOPT = MAX( LOPT, INT( WORK( M+NP+1 ) ) ) +* +* Solve T22*y2 = d2 for y2 +* + IF( N.GT.M ) THEN + CALL DTRTRS( 'Upper', 'No transpose', 'Non unit', N-M, 1, + $ B( M+1, M+P-N+1 ), LDB, D( M+1 ), N-M, INFO ) +* + IF( INFO.GT.0 ) THEN + INFO = 1 + RETURN + END IF +* + CALL DCOPY( N-M, D( M+1 ), 1, Y( M+P-N+1 ), 1 ) + END IF +* +* Set y1 = 0 +* + DO 10 I = 1, M + P - N + Y( I ) = ZERO + 10 CONTINUE +* +* Update d1 = d1 - T12*y2 +* + CALL DGEMV( 'No transpose', M, N-M, -ONE, B( 1, M+P-N+1 ), LDB, + $ Y( M+P-N+1 ), 1, ONE, D, 1 ) +* +* Solve triangular system: R11*x = d1 +* + IF( M.GT.0 ) THEN + CALL DTRTRS( 'Upper', 'No Transpose', 'Non unit', M, 1, A, LDA, + $ D, M, INFO ) +* + IF( INFO.GT.0 ) THEN + INFO = 2 + RETURN + END IF +* +* Copy D to X +* + CALL DCOPY( M, D, 1, X, 1 ) + END IF +* +* Backward transformation y = Z**T *y +* + CALL DORMRQ( 'Left', 'Transpose', P, 1, NP, + $ B( MAX( 1, N-P+1 ), 1 ), LDB, WORK( M+1 ), Y, + $ MAX( 1, P ), WORK( M+NP+1 ), LWORK-M-NP, INFO ) + WORK( 1 ) = M + NP + MAX( LOPT, INT( WORK( M+NP+1 ) ) ) +* + RETURN +* +* End of DGGGLM +* + END diff --git a/math/lapack/src/main/fortran/dgghd3.f b/math/lapack/src/main/fortran/dgghd3.f new file mode 100644 index 0000000000..034e94389d --- /dev/null +++ b/math/lapack/src/main/fortran/dgghd3.f @@ -0,0 +1,896 @@ +*> \brief \b DGGHD3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGHD3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, +* LDQ, Z, LDZ, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER COMPQ, COMPZ +* INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N, LWORK +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), +* $ Z( LDZ, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGGHD3 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 DGGHD3 reduces the original +*> problem to generalized Hessenberg form. +*> +*> This is a blocked variant of DGGHRD, using matrix-matrix +*> multiplications for parts of the computation to enhance performance. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] COMPQ +*> \verbatim +*> COMPQ is 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. +*> \endverbatim +*> +*> \param[in] COMPZ +*> \verbatim +*> COMPZ is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is 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 DGGBAL; 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. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the N-by-N general matrix to be reduced. +*> On exit, the upper triangle and the first subdiagonal of A +*> are overwritten with the upper Hessenberg matrix H, and the +*> rest is set to zero. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is 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'. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. +*> LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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'. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. +*> LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1. +*> For optimum performance LWORK >= 6*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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date January 2015 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> This routine reduces A to Hessenberg form and maintains B in +*> using a blocked variant of Moler and Stewart's original algorithm, +*> as described by Kagstrom, Kressner, Quintana-Orti, and Quintana-Orti +*> (BIT 2008). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, + $ LDQ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.6.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ + INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N, LWORK +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), + $ Z( LDZ, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL BLK22, INITQ, INITZ, LQUERY, WANTQ, WANTZ + CHARACTER*1 COMPQ2, COMPZ2 + INTEGER COLA, I, IERR, J, J0, JCOL, JJ, JROW, K, + $ KACC22, LEN, LWKOPT, N2NB, NB, NBLST, NBMIN, + $ NH, NNB, NX, PPW, PPWO, PW, TOP, TOPQ + DOUBLE PRECISION C, C1, C2, S, S1, S2, TEMP, TEMP1, TEMP2, TEMP3 +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGGHRD, DLARTG, DLASET, DORM22, DROT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters. +* + INFO = 0 + NB = ILAENV( 1, 'DGGHD3', ' ', N, ILO, IHI, -1 ) + LWKOPT = MAX( 6*N*NB, 1 ) + WORK( 1 ) = DBLE( LWKOPT ) + INITQ = LSAME( COMPQ, 'I' ) + WANTQ = INITQ .OR. LSAME( COMPQ, 'V' ) + INITZ = LSAME( COMPZ, 'I' ) + WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) + LQUERY = ( LWORK.EQ.-1 ) +* + IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) 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 ) 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( ( WANTQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN + INFO = -11 + ELSE IF( ( WANTZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -13 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGHD3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Initialize Q and Z if desired. +* + IF( INITQ ) + $ CALL DLASET( 'All', N, N, ZERO, ONE, Q, LDQ ) + IF( INITZ ) + $ CALL DLASET( 'All', N, N, ZERO, ONE, Z, LDZ ) +* +* Zero out lower triangle of B. +* + IF( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2, 1), LDB ) +* +* Quick return if possible +* + NH = IHI - ILO + 1 + IF( NH.LE.1 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* +* Determine the blocksize. +* + NBMIN = ILAENV( 2, 'DGGHD3', ' ', N, ILO, IHI, -1 ) + IF( NB.GT.1 .AND. NB.LT.NH ) THEN +* +* Determine when to use unblocked instead of blocked code. +* + NX = MAX( NB, ILAENV( 3, 'DGGHD3', ' ', N, ILO, IHI, -1 ) ) + IF( NX.LT.NH ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) 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, 'DGGHD3', ' ', N, ILO, IHI, + $ -1 ) ) + IF( LWORK.GE.6*N*NBMIN ) THEN + NB = LWORK / ( 6*N ) + ELSE + NB = 1 + END IF + END IF + END IF + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN +* +* Use unblocked code below +* + JCOL = ILO +* + ELSE +* +* Use blocked code +* + KACC22 = ILAENV( 16, 'DGGHD3', ' ', N, ILO, IHI, -1 ) + BLK22 = KACC22.EQ.2 + DO JCOL = ILO, IHI-2, NB + NNB = MIN( NB, IHI-JCOL-1 ) +* +* Initialize small orthogonal factors that will hold the +* accumulated Givens rotations in workspace. +* N2NB denotes the number of 2*NNB-by-2*NNB factors +* NBLST denotes the (possibly smaller) order of the last +* factor. +* + N2NB = ( IHI-JCOL-1 ) / NNB - 1 + NBLST = IHI - JCOL - N2NB*NNB + CALL DLASET( 'All', NBLST, NBLST, ZERO, ONE, WORK, NBLST ) + PW = NBLST * NBLST + 1 + DO I = 1, N2NB + CALL DLASET( 'All', 2*NNB, 2*NNB, ZERO, ONE, + $ WORK( PW ), 2*NNB ) + PW = PW + 4*NNB*NNB + END DO +* +* Reduce columns JCOL:JCOL+NNB-1 of A to Hessenberg form. +* + DO J = JCOL, JCOL+NNB-1 +* +* Reduce Jth column of A. Store cosines and sines in Jth +* column of A and B, respectively. +* + DO I = IHI, J+2, -1 + TEMP = A( I-1, J ) + CALL DLARTG( TEMP, A( I, J ), C, S, A( I-1, J ) ) + A( I, J ) = C + B( I, J ) = S + END DO +* +* Accumulate Givens rotations into workspace array. +* + PPW = ( NBLST + 1 )*( NBLST - 2 ) - J + JCOL + 1 + LEN = 2 + J - JCOL + JROW = J + N2NB*NNB + 2 + DO I = IHI, JROW, -1 + C = A( I, J ) + S = B( I, J ) + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + NBLST ) + WORK( JJ + NBLST ) = C*TEMP - S*WORK( JJ ) + WORK( JJ ) = S*TEMP + C*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - NBLST - 1 + END DO +* + PPWO = NBLST*NBLST + ( NNB+J-JCOL-1 )*2*NNB + NNB + J0 = JROW - NNB + DO JROW = J0, J+2, -NNB + PPW = PPWO + LEN = 2 + J - JCOL + DO I = JROW+NNB-1, JROW, -1 + C = A( I, J ) + S = B( I, J ) + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + 2*NNB ) + WORK( JJ + 2*NNB ) = C*TEMP - S*WORK( JJ ) + WORK( JJ ) = S*TEMP + C*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - 2*NNB - 1 + END DO + PPWO = PPWO + 4*NNB*NNB + END DO +* +* TOP denotes the number of top rows in A and B that will +* not be updated during the next steps. +* + IF( JCOL.LE.2 ) THEN + TOP = 0 + ELSE + TOP = JCOL + END IF +* +* Propagate transformations through B and replace stored +* left sines/cosines by right sines/cosines. +* + DO JJ = N, J+1, -1 +* +* Update JJth column of B. +* + DO I = MIN( JJ+1, IHI ), J+2, -1 + C = A( I, J ) + S = B( I, J ) + TEMP = B( I, JJ ) + B( I, JJ ) = C*TEMP - S*B( I-1, JJ ) + B( I-1, JJ ) = S*TEMP + C*B( I-1, JJ ) + END DO +* +* Annihilate B( JJ+1, JJ ). +* + IF( JJ.LT.IHI ) THEN + TEMP = B( JJ+1, JJ+1 ) + CALL DLARTG( TEMP, B( JJ+1, JJ ), C, S, + $ B( JJ+1, JJ+1 ) ) + B( JJ+1, JJ ) = ZERO + CALL DROT( JJ-TOP, B( TOP+1, JJ+1 ), 1, + $ B( TOP+1, JJ ), 1, C, S ) + A( JJ+1, J ) = C + B( JJ+1, J ) = -S + END IF + END DO +* +* Update A by transformations from right. +* Explicit loop unrolling provides better performance +* compared to DLASR. +* CALL DLASR( 'Right', 'Variable', 'Backward', IHI-TOP, +* $ IHI-J, A( J+2, J ), B( J+2, J ), +* $ A( TOP+1, J+1 ), LDA ) +* + JJ = MOD( IHI-J-1, 3 ) + DO I = IHI-J-3, JJ+1, -3 + C = A( J+1+I, J ) + S = -B( J+1+I, J ) + C1 = A( J+2+I, J ) + S1 = -B( J+2+I, J ) + C2 = A( J+3+I, J ) + S2 = -B( J+3+I, J ) +* + DO K = TOP+1, IHI + TEMP = A( K, J+I ) + TEMP1 = A( K, J+I+1 ) + TEMP2 = A( K, J+I+2 ) + TEMP3 = A( K, J+I+3 ) + A( K, J+I+3 ) = C2*TEMP3 + S2*TEMP2 + TEMP2 = -S2*TEMP3 + C2*TEMP2 + A( K, J+I+2 ) = C1*TEMP2 + S1*TEMP1 + TEMP1 = -S1*TEMP2 + C1*TEMP1 + A( K, J+I+1 ) = C*TEMP1 + S*TEMP + A( K, J+I ) = -S*TEMP1 + C*TEMP + END DO + END DO +* + IF( JJ.GT.0 ) THEN + DO I = JJ, 1, -1 + CALL DROT( IHI-TOP, A( TOP+1, J+I+1 ), 1, + $ A( TOP+1, J+I ), 1, A( J+1+I, J ), + $ -B( J+1+I, J ) ) + END DO + END IF +* +* Update (J+1)th column of A by transformations from left. +* + IF ( J .LT. JCOL + NNB - 1 ) THEN + LEN = 1 + J - JCOL +* +* Multiply with the trailing accumulated orthogonal +* matrix, which takes the form +* +* [ U11 U12 ] +* U = [ ], +* [ U21 U22 ] +* +* where U21 is a LEN-by-LEN matrix and U12 is lower +* triangular. +* + JROW = IHI - NBLST + 1 + CALL DGEMV( 'Transpose', NBLST, LEN, ONE, WORK, + $ NBLST, A( JROW, J+1 ), 1, ZERO, + $ WORK( PW ), 1 ) + PPW = PW + LEN + DO I = JROW, JROW+NBLST-LEN-1 + WORK( PPW ) = A( I, J+1 ) + PPW = PPW + 1 + END DO + CALL DTRMV( 'Lower', 'Transpose', 'Non-unit', + $ NBLST-LEN, WORK( LEN*NBLST + 1 ), NBLST, + $ WORK( PW+LEN ), 1 ) + CALL DGEMV( 'Transpose', LEN, NBLST-LEN, ONE, + $ WORK( (LEN+1)*NBLST - LEN + 1 ), NBLST, + $ A( JROW+NBLST-LEN, J+1 ), 1, ONE, + $ WORK( PW+LEN ), 1 ) + PPW = PW + DO I = JROW, JROW+NBLST-1 + A( I, J+1 ) = WORK( PPW ) + PPW = PPW + 1 + END DO +* +* Multiply with the other accumulated orthogonal +* matrices, which take the form +* +* [ U11 U12 0 ] +* [ ] +* U = [ U21 U22 0 ], +* [ ] +* [ 0 0 I ] +* +* where I denotes the (NNB-LEN)-by-(NNB-LEN) identity +* matrix, U21 is a LEN-by-LEN upper triangular matrix +* and U12 is an NNB-by-NNB lower triangular matrix. +* + PPWO = 1 + NBLST*NBLST + J0 = JROW - NNB + DO JROW = J0, JCOL+1, -NNB + PPW = PW + LEN + DO I = JROW, JROW+NNB-1 + WORK( PPW ) = A( I, J+1 ) + PPW = PPW + 1 + END DO + PPW = PW + DO I = JROW+NNB, JROW+NNB+LEN-1 + WORK( PPW ) = A( I, J+1 ) + PPW = PPW + 1 + END DO + CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', LEN, + $ WORK( PPWO + NNB ), 2*NNB, WORK( PW ), + $ 1 ) + CALL DTRMV( 'Lower', 'Transpose', 'Non-unit', NNB, + $ WORK( PPWO + 2*LEN*NNB ), + $ 2*NNB, WORK( PW + LEN ), 1 ) + CALL DGEMV( 'Transpose', NNB, LEN, ONE, + $ WORK( PPWO ), 2*NNB, A( JROW, J+1 ), 1, + $ ONE, WORK( PW ), 1 ) + CALL DGEMV( 'Transpose', LEN, NNB, ONE, + $ WORK( PPWO + 2*LEN*NNB + NNB ), 2*NNB, + $ A( JROW+NNB, J+1 ), 1, ONE, + $ WORK( PW+LEN ), 1 ) + PPW = PW + DO I = JROW, JROW+LEN+NNB-1 + A( I, J+1 ) = WORK( PPW ) + PPW = PPW + 1 + END DO + PPWO = PPWO + 4*NNB*NNB + END DO + END IF + END DO +* +* Apply accumulated orthogonal matrices to A. +* + COLA = N - JCOL - NNB + 1 + J = IHI - NBLST + 1 + CALL DGEMM( 'Transpose', 'No Transpose', NBLST, + $ COLA, NBLST, ONE, WORK, NBLST, + $ A( J, JCOL+NNB ), LDA, ZERO, WORK( PW ), + $ NBLST ) + CALL DLACPY( 'All', NBLST, COLA, WORK( PW ), NBLST, + $ A( J, JCOL+NNB ), LDA ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( BLK22 ) THEN +* +* Exploit the structure of +* +* [ U11 U12 ] +* U = [ ] +* [ U21 U22 ], +* +* where all blocks are NNB-by-NNB, U21 is upper +* triangular and U12 is lower triangular. +* + CALL DORM22( 'Left', 'Transpose', 2*NNB, COLA, NNB, + $ NNB, WORK( PPWO ), 2*NNB, + $ A( J, JCOL+NNB ), LDA, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL DGEMM( 'Transpose', 'No Transpose', 2*NNB, + $ COLA, 2*NNB, ONE, WORK( PPWO ), 2*NNB, + $ A( J, JCOL+NNB ), LDA, ZERO, WORK( PW ), + $ 2*NNB ) + CALL DLACPY( 'All', 2*NNB, COLA, WORK( PW ), 2*NNB, + $ A( J, JCOL+NNB ), LDA ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO +* +* Apply accumulated orthogonal matrices to Q. +* + IF( WANTQ ) THEN + J = IHI - NBLST + 1 + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + ELSE + TOPQ = 1 + NH = N + END IF + CALL DGEMM( 'No Transpose', 'No Transpose', NH, + $ NBLST, NBLST, ONE, Q( TOPQ, J ), LDQ, + $ WORK, NBLST, ZERO, WORK( PW ), NH ) + CALL DLACPY( 'All', NH, NBLST, WORK( PW ), NH, + $ Q( TOPQ, J ), LDQ ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + END IF + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL DORM22( 'Right', 'No Transpose', NH, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ Q( TOPQ, J ), LDQ, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL DGEMM( 'No Transpose', 'No Transpose', NH, + $ 2*NNB, 2*NNB, ONE, Q( TOPQ, J ), LDQ, + $ WORK( PPWO ), 2*NNB, ZERO, WORK( PW ), + $ NH ) + CALL DLACPY( 'All', NH, 2*NNB, WORK( PW ), NH, + $ Q( TOPQ, J ), LDQ ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO + END IF +* +* Accumulate right Givens rotations if required. +* + IF ( WANTZ .OR. TOP.GT.0 ) THEN +* +* Initialize small orthogonal factors that will hold the +* accumulated Givens rotations in workspace. +* + CALL DLASET( 'All', NBLST, NBLST, ZERO, ONE, WORK, + $ NBLST ) + PW = NBLST * NBLST + 1 + DO I = 1, N2NB + CALL DLASET( 'All', 2*NNB, 2*NNB, ZERO, ONE, + $ WORK( PW ), 2*NNB ) + PW = PW + 4*NNB*NNB + END DO +* +* Accumulate Givens rotations into workspace array. +* + DO J = JCOL, JCOL+NNB-1 + PPW = ( NBLST + 1 )*( NBLST - 2 ) - J + JCOL + 1 + LEN = 2 + J - JCOL + JROW = J + N2NB*NNB + 2 + DO I = IHI, JROW, -1 + C = A( I, J ) + A( I, J ) = ZERO + S = B( I, J ) + B( I, J ) = ZERO + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + NBLST ) + WORK( JJ + NBLST ) = C*TEMP - S*WORK( JJ ) + WORK( JJ ) = S*TEMP + C*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - NBLST - 1 + END DO +* + PPWO = NBLST*NBLST + ( NNB+J-JCOL-1 )*2*NNB + NNB + J0 = JROW - NNB + DO JROW = J0, J+2, -NNB + PPW = PPWO + LEN = 2 + J - JCOL + DO I = JROW+NNB-1, JROW, -1 + C = A( I, J ) + A( I, J ) = ZERO + S = B( I, J ) + B( I, J ) = ZERO + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + 2*NNB ) + WORK( JJ + 2*NNB ) = C*TEMP - S*WORK( JJ ) + WORK( JJ ) = S*TEMP + C*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - 2*NNB - 1 + END DO + PPWO = PPWO + 4*NNB*NNB + END DO + END DO + ELSE +* + CALL DLASET( 'Lower', IHI - JCOL - 1, NNB, ZERO, ZERO, + $ A( JCOL + 2, JCOL ), LDA ) + CALL DLASET( 'Lower', IHI - JCOL - 1, NNB, ZERO, ZERO, + $ B( JCOL + 2, JCOL ), LDB ) + END IF +* +* Apply accumulated orthogonal matrices to A and B. +* + IF ( TOP.GT.0 ) THEN + J = IHI - NBLST + 1 + CALL DGEMM( 'No Transpose', 'No Transpose', TOP, + $ NBLST, NBLST, ONE, A( 1, J ), LDA, + $ WORK, NBLST, ZERO, WORK( PW ), TOP ) + CALL DLACPY( 'All', TOP, NBLST, WORK( PW ), TOP, + $ A( 1, J ), LDA ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL DORM22( 'Right', 'No Transpose', TOP, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ A( 1, J ), LDA, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL DGEMM( 'No Transpose', 'No Transpose', TOP, + $ 2*NNB, 2*NNB, ONE, A( 1, J ), LDA, + $ WORK( PPWO ), 2*NNB, ZERO, + $ WORK( PW ), TOP ) + CALL DLACPY( 'All', TOP, 2*NNB, WORK( PW ), TOP, + $ A( 1, J ), LDA ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO +* + J = IHI - NBLST + 1 + CALL DGEMM( 'No Transpose', 'No Transpose', TOP, + $ NBLST, NBLST, ONE, B( 1, J ), LDB, + $ WORK, NBLST, ZERO, WORK( PW ), TOP ) + CALL DLACPY( 'All', TOP, NBLST, WORK( PW ), TOP, + $ B( 1, J ), LDB ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL DORM22( 'Right', 'No Transpose', TOP, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ B( 1, J ), LDB, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL DGEMM( 'No Transpose', 'No Transpose', TOP, + $ 2*NNB, 2*NNB, ONE, B( 1, J ), LDB, + $ WORK( PPWO ), 2*NNB, ZERO, + $ WORK( PW ), TOP ) + CALL DLACPY( 'All', TOP, 2*NNB, WORK( PW ), TOP, + $ B( 1, J ), LDB ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO + END IF +* +* Apply accumulated orthogonal matrices to Z. +* + IF( WANTZ ) THEN + J = IHI - NBLST + 1 + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + ELSE + TOPQ = 1 + NH = N + END IF + CALL DGEMM( 'No Transpose', 'No Transpose', NH, + $ NBLST, NBLST, ONE, Z( TOPQ, J ), LDZ, + $ WORK, NBLST, ZERO, WORK( PW ), NH ) + CALL DLACPY( 'All', NH, NBLST, WORK( PW ), NH, + $ Z( TOPQ, J ), LDZ ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + END IF + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL DORM22( 'Right', 'No Transpose', NH, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ Z( TOPQ, J ), LDZ, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL DGEMM( 'No Transpose', 'No Transpose', NH, + $ 2*NNB, 2*NNB, ONE, Z( TOPQ, J ), LDZ, + $ WORK( PPWO ), 2*NNB, ZERO, WORK( PW ), + $ NH ) + CALL DLACPY( 'All', NH, 2*NNB, WORK( PW ), NH, + $ Z( TOPQ, J ), LDZ ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO + END IF + END DO + END IF +* +* Use unblocked code to reduce the rest of the matrix +* Avoid re-initialization of modified Q and Z. +* + COMPQ2 = COMPQ + COMPZ2 = COMPZ + IF ( JCOL.NE.ILO ) THEN + IF ( WANTQ ) + $ COMPQ2 = 'V' + IF ( WANTZ ) + $ COMPZ2 = 'V' + END IF +* + IF ( JCOL.LT.IHI ) + $ CALL DGGHRD( COMPQ2, COMPZ2, N, JCOL, IHI, A, LDA, B, LDB, Q, + $ LDQ, Z, LDZ, IERR ) + WORK( 1 ) = DBLE( LWKOPT ) +* + RETURN +* +* End of DGGHD3 +* + END diff --git a/math/lapack/src/main/fortran/dgghrd.f b/math/lapack/src/main/fortran/dgghrd.f new file mode 100644 index 0000000000..3a74899d1c --- /dev/null +++ b/math/lapack/src/main/fortran/dgghrd.f @@ -0,0 +1,361 @@ +*> \brief \b DGGHRD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, +* LDQ, Z, LDZ, INFO ) +* +* .. 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] COMPQ +*> \verbatim +*> COMPQ is 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. +*> \endverbatim +*> +*> \param[in] COMPZ +*> \verbatim +*> COMPZ is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is 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 DGGBAL; 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. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the N-by-N general matrix to be reduced. +*> On exit, the upper triangle and the first subdiagonal of A +*> are overwritten with the upper Hessenberg matrix H, and the +*> rest is set to zero. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is 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'. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. +*> LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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'. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. +*> LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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.) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, + $ LDQ, Z, LDZ, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dgglse.f b/math/lapack/src/main/fortran/dgglse.f new file mode 100644 index 0000000000..5d5cac23b6 --- /dev/null +++ b/math/lapack/src/main/fortran/dgglse.f @@ -0,0 +1,354 @@ +*> \brief DGGLSE solves overdetermined or underdetermined systems for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGLSE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LWORK, M, N, P +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( * ), D( * ), +* $ WORK( * ), X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGGLSE solves the linear equality-constrained least squares (LSE) +*> problem: +*> +*> minimize || c - A*x ||_2 subject to B*x = d +*> +*> where A is an M-by-N matrix, B is a P-by-N matrix, c is a given +*> M-vector, and d is a given P-vector. It is assumed that +*> P <= N <= M+P, and +*> +*> rank(B) = P and rank( (A) ) = N. +*> ( (B) ) +*> +*> These conditions ensure that the LSE problem has a unique solution, +*> which is obtained using a generalized RQ factorization of the +*> matrices (B, A) given by +*> +*> B = (0 R)*Q, A = Z*T*Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows of the matrix B. 0 <= P <= N <= M+P. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(M,N)-by-N upper trapezoidal matrix T. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the P-by-N matrix B. +*> On exit, the upper triangle of the subarray B(1:P,N-P+1:N) +*> contains the P-by-P upper triangular matrix R. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,P). +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (M) +*> On entry, C contains the right hand side vector for the +*> least squares part of the LSE problem. +*> On exit, the residual sum of squares for the solution +*> is given by the sum of squares of elements N-P+1 to M of +*> vector C. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (P) +*> On entry, D contains the right hand side vector for the +*> constrained equation. +*> On exit, D is destroyed. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (N) +*> On exit, X is the solution of the LSE problem. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= max(1,M+N+P). +*> For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB, +*> where NB is an upper bound for the optimal blocksizes for +*> DGEQRF, SGERQF, DORMQR and SORMRQ. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> = 1: the upper triangular factor R associated with B in the +*> generalized RQ factorization of the pair (B, A) is +*> singular, so that rank(B) < P; the least squares +*> solution could not be computed. +*> = 2: the (N-P) by (N-P) part of the upper trapezoidal factor +*> T associated with A in the generalized RQ factorization +*> of the pair (B, A) is singular, so that +*> rank( (A) ) < N; the least squares solution could not +*> ( (B) ) +*> be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERsolve +* +* ===================================================================== + SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, + $ INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LWORK, M, N, P +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( * ), D( * ), + $ WORK( * ), X( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LOPT, LWKMIN, LWKOPT, MN, NB, NB1, NB2, NB3, + $ NB4, NR +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGGRQF, DORMQR, DORMRQ, + $ DTRMV, DTRTRS, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + MN = MIN( M, N ) + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 .OR. P.GT.N .OR. P.LT.N-M ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, P ) ) THEN + INFO = -7 + END IF +* +* Calculate workspace +* + IF( INFO.EQ.0) THEN + IF( N.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, P, -1 ) + NB4 = ILAENV( 1, 'DORMRQ', ' ', M, N, P, -1 ) + NB = MAX( NB1, NB2, NB3, NB4 ) + LWKMIN = M + N + P + LWKOPT = P + MN + MAX( M, N )*NB + 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( 'DGGLSE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Compute the GRQ factorization of matrices B and A: +* +* B*Q**T = ( 0 T12 ) P Z**T*A*Q**T = ( R11 R12 ) N-P +* N-P P ( 0 R22 ) M+P-N +* N-P P +* +* where T12 and R11 are upper triangular, and Q and Z are +* orthogonal. +* + CALL DGGRQF( P, M, N, B, LDB, WORK, A, LDA, WORK( P+1 ), + $ WORK( P+MN+1 ), LWORK-P-MN, INFO ) + LOPT = WORK( P+MN+1 ) +* +* Update c = Z**T *c = ( c1 ) N-P +* ( c2 ) M+P-N +* + CALL DORMQR( 'Left', 'Transpose', M, 1, MN, A, LDA, WORK( P+1 ), + $ C, MAX( 1, M ), WORK( P+MN+1 ), LWORK-P-MN, INFO ) + LOPT = MAX( LOPT, INT( WORK( P+MN+1 ) ) ) +* +* Solve T12*x2 = d for x2 +* + IF( P.GT.0 ) THEN + CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', P, 1, + $ B( 1, N-P+1 ), LDB, D, P, INFO ) +* + IF( INFO.GT.0 ) THEN + INFO = 1 + RETURN + END IF +* +* Put the solution in X +* + CALL DCOPY( P, D, 1, X( N-P+1 ), 1 ) +* +* Update c1 +* + CALL DGEMV( 'No transpose', N-P, P, -ONE, A( 1, N-P+1 ), LDA, + $ D, 1, ONE, C, 1 ) + END IF +* +* Solve R11*x1 = c1 for x1 +* + IF( N.GT.P ) THEN + CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', N-P, 1, + $ A, LDA, C, N-P, INFO ) +* + IF( INFO.GT.0 ) THEN + INFO = 2 + RETURN + END IF +* +* Put the solutions in X +* + CALL DCOPY( N-P, C, 1, X, 1 ) + END IF +* +* Compute the residual vector: +* + IF( M.LT.N ) THEN + NR = M + P - N + IF( NR.GT.0 ) + $ CALL DGEMV( 'No transpose', NR, N-M, -ONE, A( N-P+1, M+1 ), + $ LDA, D( NR+1 ), 1, ONE, C( N-P+1 ), 1 ) + ELSE + NR = P + END IF + IF( NR.GT.0 ) THEN + CALL DTRMV( 'Upper', 'No transpose', 'Non unit', NR, + $ A( N-P+1, N-P+1 ), LDA, D, 1 ) + CALL DAXPY( NR, -ONE, D, 1, C( N-P+1 ), 1 ) + END IF +* +* Backward transformation x = Q**T*x +* + CALL DORMRQ( 'Left', 'Transpose', N, 1, P, B, LDB, WORK( 1 ), X, + $ N, WORK( P+MN+1 ), LWORK-P-MN, INFO ) + WORK( 1 ) = P + MN + MAX( LOPT, INT( WORK( P+MN+1 ) ) ) +* + RETURN +* +* End of DGGLSE +* + END diff --git a/math/lapack/src/main/fortran/dggqrf.f b/math/lapack/src/main/fortran/dggqrf.f new file mode 100644 index 0000000000..3ce21d8fd9 --- /dev/null +++ b/math/lapack/src/main/fortran/dggqrf.f @@ -0,0 +1,299 @@ +*> \brief \b DGGQRF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGQRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LWORK, M, N, P +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGGQRF computes a generalized QR factorization of an N-by-M matrix A +*> and an N-by-P matrix B: +*> +*> A = Q*R, B = Q*T*Z, +*> +*> where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal +*> matrix, and R and T assume one of the forms: +*> +*> if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N, +*> ( 0 ) N-M N M-N +*> M +*> +*> where R11 is upper triangular, and +*> +*> if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P, +*> P-N N ( T21 ) P +*> P +*> +*> where T12 or T21 is upper triangular. +*> +*> In particular, if B is square and nonsingular, the GQR factorization +*> of A and B implicitly gives the QR factorization of inv(B)*A: +*> +*> inv(B)*A = Z**T*(inv(T)*R) +*> +*> where inv(B) denotes the inverse of the matrix B, and Z**T denotes the +*> transpose of the matrix Z. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of columns of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of columns of the matrix B. P >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,M) +*> On entry, the N-by-M matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(N,M)-by-M upper trapezoidal matrix R (R is +*> upper triangular if N >= M); the elements below the diagonal, +*> with the array TAUA, represent the orthogonal matrix Q as a +*> product of min(N,M) elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] TAUA +*> \verbatim +*> TAUA is DOUBLE PRECISION array, dimension (min(N,M)) +*> The scalar factors of the elementary reflectors which +*> represent the orthogonal matrix Q (see Further Details). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,P) +*> On entry, the N-by-P matrix B. +*> On exit, if N <= P, the upper triangle of the subarray +*> B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; +*> if N > P, the elements on and above the (N-P)-th subdiagonal +*> contain the N-by-P upper trapezoidal matrix T; the remaining +*> elements, with the array TAUB, represent the orthogonal +*> matrix Z as a product of elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] TAUB +*> \verbatim +*> TAUB is DOUBLE PRECISION array, dimension (min(N,P)) +*> The scalar factors of the elementary reflectors which +*> represent the orthogonal matrix Z (see Further Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= max(1,N,M,P). +*> For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), +*> where NB1 is the optimal blocksize for the QR factorization +*> of an N-by-M matrix, NB2 is the optimal blocksize for the +*> RQ factorization of an N-by-P matrix, and NB3 is the optimal +*> blocksize for a call of DORMQR. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = min(n,m). +*> +*> Each H(i) has the form +*> +*> H(i) = I - taua * v * v**T +*> +*> where taua is a real scalar, and v is a real vector with +*> v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), +*> and taua in TAUA(i). +*> To form Q explicitly, use LAPACK subroutine DORGQR. +*> To use Q to update another matrix, use LAPACK subroutine DORMQR. +*> +*> The matrix Z is represented as a product of elementary reflectors +*> +*> Z = H(1) H(2) . . . H(k), where k = min(n,p). +*> +*> Each H(i) has the form +*> +*> H(i) = I - taub * v * v**T +*> +*> where taub is a real scalar, and v is a real vector with +*> v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in +*> B(n-k+i,1:p-k+i-1), and taub in TAUB(i). +*> To form Z explicitly, use LAPACK subroutine DORGRQ. +*> To use Z to update another matrix, use LAPACK subroutine DORMRQ. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LWORK, M, N, P +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3 +* .. +* .. External Subroutines .. + EXTERNAL DGEQRF, DGERQF, DORMQR, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + NB1 = ILAENV( 1, 'DGEQRF', ' ', N, M, -1, -1 ) + NB2 = ILAENV( 1, 'DGERQF', ' ', N, P, -1, -1 ) + NB3 = ILAENV( 1, 'DORMQR', ' ', N, M, P, -1 ) + NB = MAX( NB1, NB2, NB3 ) + LWKOPT = MAX( N, M, P )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.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.MAX( 1, N, M, P ) .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGQRF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* QR factorization of N-by-M matrix A: A = Q*R +* + CALL DGEQRF( N, M, A, LDA, TAUA, WORK, LWORK, INFO ) + LOPT = WORK( 1 ) +* +* Update B := Q**T*B. +* + CALL DORMQR( 'Left', 'Transpose', N, P, MIN( N, M ), A, LDA, TAUA, + $ B, LDB, WORK, LWORK, INFO ) + LOPT = MAX( LOPT, INT( WORK( 1 ) ) ) +* +* RQ factorization of N-by-P matrix B: B = T*Z. +* + CALL DGERQF( N, P, B, LDB, TAUB, WORK, LWORK, INFO ) + WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) ) +* + RETURN +* +* End of DGGQRF +* + END diff --git a/math/lapack/src/main/fortran/dggrqf.f b/math/lapack/src/main/fortran/dggrqf.f new file mode 100644 index 0000000000..9c377cc5a6 --- /dev/null +++ b/math/lapack/src/main/fortran/dggrqf.f @@ -0,0 +1,299 @@ +*> \brief \b DGGRQF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGRQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LWORK, M, N, P +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGGRQF computes a generalized RQ factorization of an M-by-N matrix A +*> and a P-by-N matrix B: +*> +*> A = R*Q, B = Z*T*Q, +*> +*> where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal +*> matrix, and R and T assume one of the forms: +*> +*> if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N, +*> N-M M ( R21 ) N +*> N +*> +*> where R12 or R21 is upper triangular, and +*> +*> if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P, +*> ( 0 ) P-N P N-P +*> N +*> +*> where T11 is upper triangular. +*> +*> In particular, if B is square and nonsingular, the GRQ factorization +*> of A and B implicitly gives the RQ factorization of A*inv(B): +*> +*> A*inv(B) = (R*inv(T))*Z**T +*> +*> where inv(B) denotes the inverse of the matrix B, and Z**T denotes the +*> transpose of the matrix Z. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows of the matrix B. P >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, if M <= N, the upper triangle of the subarray +*> A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R; +*> if M > N, the elements on and above the (M-N)-th subdiagonal +*> contain the M-by-N upper trapezoidal matrix R; the remaining +*> elements, with the array TAUA, represent the orthogonal +*> matrix Q as a product of elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAUA +*> \verbatim +*> TAUA is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors which +*> represent the orthogonal matrix Q (see Further Details). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the P-by-N matrix B. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(P,N)-by-N upper trapezoidal matrix T (T is +*> upper triangular if P >= N); the elements below the diagonal, +*> with the array TAUB, represent the orthogonal matrix Z as a +*> product of elementary reflectors (see Further Details). +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,P). +*> \endverbatim +*> +*> \param[out] TAUB +*> \verbatim +*> TAUB is DOUBLE PRECISION array, dimension (min(P,N)) +*> The scalar factors of the elementary reflectors which +*> represent the orthogonal matrix Z (see Further Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= max(1,N,M,P). +*> For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), +*> where NB1 is the optimal blocksize for the RQ factorization +*> of an M-by-N matrix, NB2 is the optimal blocksize for the +*> QR factorization of a P-by-N matrix, and NB3 is the optimal +*> blocksize for a call of DORMRQ. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INF0= -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - taua * v * v**T +*> +*> where taua is a real scalar, and v is a real vector with +*> v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in +*> A(m-k+i,1:n-k+i-1), and taua in TAUA(i). +*> To form Q explicitly, use LAPACK subroutine DORGRQ. +*> To use Q to update another matrix, use LAPACK subroutine DORMRQ. +*> +*> The matrix Z is represented as a product of elementary reflectors +*> +*> Z = H(1) H(2) . . . H(k), where k = min(p,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - taub * v * v**T +*> +*> where taub is a real scalar, and v is a real vector with +*> v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i), +*> and taub in TAUB(i). +*> To form Z explicitly, use LAPACK subroutine DORGQR. +*> To use Z to update another matrix, use LAPACK subroutine DORMQR. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LWORK, M, N, P +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3 +* .. +* .. External Subroutines .. + EXTERNAL DGEQRF, DGERQF, DORMRQ, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + NB1 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 ) + NB2 = ILAENV( 1, 'DGEQRF', ' ', P, N, -1, -1 ) + NB3 = ILAENV( 1, 'DORMRQ', ' ', M, N, P, -1 ) + NB = MAX( NB1, NB2, NB3 ) + LWKOPT = MAX( N, M, P )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( P.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, P ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.MAX( 1, M, P, N ) .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGRQF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* RQ factorization of M-by-N matrix A: A = R*Q +* + CALL DGERQF( M, N, A, LDA, TAUA, WORK, LWORK, INFO ) + LOPT = WORK( 1 ) +* +* Update B := B*Q**T +* + CALL DORMRQ( 'Right', 'Transpose', P, N, MIN( M, N ), + $ A( MAX( 1, M-N+1 ), 1 ), LDA, TAUA, B, LDB, WORK, + $ LWORK, INFO ) + LOPT = MAX( LOPT, INT( WORK( 1 ) ) ) +* +* QR factorization of P-by-N matrix B: B = Z*T +* + CALL DGEQRF( P, N, B, LDB, TAUB, WORK, LWORK, INFO ) + WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) ) +* + RETURN +* +* End of DGGRQF +* + END diff --git a/math/lapack/src/main/fortran/dggsvd3.f b/math/lapack/src/main/fortran/dggsvd3.f new file mode 100644 index 0000000000..f882139dda --- /dev/null +++ b/math/lapack/src/main/fortran/dggsvd3.f @@ -0,0 +1,503 @@ +*> \brief DGGSVD3 computes the singular value decomposition (SVD) for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGSVD3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGSVD3( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, +* LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, +* LWORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBQ, JOBU, JOBV +* INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P, LWORK +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), ALPHA( * ), B( LDB, * ), +* $ BETA( * ), Q( LDQ, * ), U( LDU, * ), +* $ V( LDV, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGGSVD3 computes the generalized singular value decomposition (GSVD) +*> of an M-by-N real matrix A and P-by-N real matrix B: +*> +*> U**T*A*Q = D1*( 0 R ), V**T*B*Q = D2*( 0 R ) +*> +*> where U, V and Q are orthogonal matrices. +*> Let K+L = the effective numerical rank of the matrix (A**T,B**T)**T, +*> then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and +*> D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the +*> following structures, respectively: +*> +*> If M-K-L >= 0, +*> +*> K L +*> D1 = K ( I 0 ) +*> L ( 0 C ) +*> M-K-L ( 0 0 ) +*> +*> K L +*> D2 = L ( 0 S ) +*> P-L ( 0 0 ) +*> +*> N-K-L K L +*> ( 0 R ) = K ( 0 R11 R12 ) +*> L ( 0 0 R22 ) +*> +*> where +*> +*> C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), +*> S = diag( BETA(K+1), ... , BETA(K+L) ), +*> C**2 + S**2 = I. +*> +*> R is stored in A(1:K+L,N-K-L+1:N) on exit. +*> +*> If M-K-L < 0, +*> +*> K M-K K+L-M +*> D1 = K ( I 0 0 ) +*> M-K ( 0 C 0 ) +*> +*> K M-K K+L-M +*> D2 = M-K ( 0 S 0 ) +*> K+L-M ( 0 0 I ) +*> P-L ( 0 0 0 ) +*> +*> N-K-L K M-K K+L-M +*> ( 0 R ) = K ( 0 R11 R12 R13 ) +*> M-K ( 0 0 R22 R23 ) +*> K+L-M ( 0 0 0 R33 ) +*> +*> where +*> +*> C = diag( ALPHA(K+1), ... , ALPHA(M) ), +*> S = diag( BETA(K+1), ... , BETA(M) ), +*> C**2 + S**2 = I. +*> +*> (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored +*> ( 0 R22 R23 ) +*> in B(M-K+1:L,N+M-K-L+1:N) on exit. +*> +*> The routine computes C, S, R, and optionally the orthogonal +*> transformation matrices U, V and Q. +*> +*> In particular, if B is an N-by-N nonsingular matrix, then the GSVD of +*> A and B implicitly gives the SVD of A*inv(B): +*> A*inv(B) = U*(D1*inv(D2))*V**T. +*> If ( A**T,B**T)**T has orthonormal columns, then the GSVD of A and B is +*> also equal to the CS decomposition of A and B. Furthermore, the GSVD +*> can be used to derive the solution of the eigenvalue problem: +*> A**T*A x = lambda* B**T*B x. +*> In some literature, the GSVD of A and B is presented in the form +*> U**T*A*X = ( 0 D1 ), V**T*B*X = ( 0 D2 ) +*> where U and V are orthogonal and X is nonsingular, D1 and D2 are +*> ``diagonal''. The former GSVD form can be converted to the latter +*> form by taking the nonsingular matrix X as +*> +*> X = Q*( I 0 ) +*> ( 0 inv(R) ). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBU +*> \verbatim +*> JOBU is CHARACTER*1 +*> = 'U': Orthogonal matrix U is computed; +*> = 'N': U is not computed. +*> \endverbatim +*> +*> \param[in] JOBV +*> \verbatim +*> JOBV is CHARACTER*1 +*> = 'V': Orthogonal matrix V is computed; +*> = 'N': V is not computed. +*> \endverbatim +*> +*> \param[in] JOBQ +*> \verbatim +*> JOBQ is CHARACTER*1 +*> = 'Q': Orthogonal matrix Q is computed; +*> = 'N': Q is not computed. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows of the matrix B. P >= 0. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> \endverbatim +*> +*> \param[out] L +*> \verbatim +*> L is INTEGER +*> +*> On exit, K and L specify the dimension of the subblocks +*> described in Purpose. +*> K + L = effective numerical rank of (A**T,B**T)**T. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, A contains the triangular matrix R, or part of R. +*> See Purpose for details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the P-by-N matrix B. +*> On exit, B contains the triangular matrix R if M-K-L < 0. +*> See Purpose for details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,P). +*> \endverbatim +*> +*> \param[out] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION array, dimension (N) +*> +*> On exit, ALPHA and BETA contain the generalized singular +*> value pairs of A and B; +*> ALPHA(1:K) = 1, +*> BETA(1:K) = 0, +*> and if M-K-L >= 0, +*> ALPHA(K+1:K+L) = C, +*> BETA(K+1:K+L) = S, +*> or if M-K-L < 0, +*> ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0 +*> BETA(K+1:M) =S, BETA(M+1:K+L) =1 +*> and +*> ALPHA(K+L+1:N) = 0 +*> BETA(K+L+1:N) = 0 +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension (LDU,M) +*> If JOBU = 'U', U contains the M-by-M orthogonal matrix U. +*> If JOBU = 'N', U is not referenced. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of the array U. LDU >= max(1,M) if +*> JOBU = 'U'; LDU >= 1 otherwise. +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,P) +*> If JOBV = 'V', V contains the P-by-P orthogonal matrix V. +*> If JOBV = 'N', V is not referenced. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. LDV >= max(1,P) if +*> JOBV = 'V'; LDV >= 1 otherwise. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ,N) +*> If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q. +*> If JOBQ = 'N', Q is not referenced. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= max(1,N) if +*> JOBQ = 'Q'; LDQ >= 1 otherwise. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> On exit, IWORK stores the sorting information. More +*> precisely, the following loop will sort ALPHA +*> for I = K+1, min(M,K+L) +*> swap ALPHA(I) and ALPHA(IWORK(I)) +*> endfor +*> such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = 1, the Jacobi-type procedure failed to +*> converge. For further details, see subroutine DTGSJA. +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> TOLA DOUBLE PRECISION +*> TOLB DOUBLE PRECISION +*> TOLA and TOLB are the thresholds to determine the effective +*> rank of (A**T,B**T)**T. Generally, they are set to +*> TOLA = MAX(M,N)*norm(A)*MACHEPS, +*> TOLB = MAX(P,N)*norm(B)*MACHEPS. +*> The size of TOLA and TOLB may affect the size of backward +*> errors of the decomposition. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date August 2015 +* +*> \ingroup doubleGEsing +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* +*> \par Further Details: +* ===================== +*> +*> DGGSVD3 replaces the deprecated subroutine DGGSVD. +*> +* ===================================================================== + SUBROUTINE DGGSVD3( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, + $ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, + $ WORK, LWORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* August 2015 +* +* .. Scalar Arguments .. + CHARACTER JOBQ, JOBU, JOBV + INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P, + $ LWORK +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), ALPHA( * ), B( LDB, * ), + $ BETA( * ), Q( LDQ, * ), U( LDU, * ), + $ V( LDV, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL WANTQ, WANTU, WANTV, LQUERY + INTEGER I, IBND, ISUB, J, NCYCLE, LWKOPT + DOUBLE PRECISION ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, DLAMCH, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGGSVP3, DTGSJA, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + WANTU = LSAME( JOBU, 'U' ) + WANTV = LSAME( JOBV, 'V' ) + WANTQ = LSAME( JOBQ, 'Q' ) + LQUERY = ( LWORK.EQ.-1 ) + LWKOPT = 1 +* +* Test the input arguments +* + INFO = 0 + IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN + INFO = -16 + ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN + INFO = -18 + ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN + INFO = -20 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -24 + END IF +* +* Compute workspace +* + IF( INFO.EQ.0 ) THEN + CALL DGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, + $ TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, WORK, + $ WORK, -1, INFO ) + LWKOPT = N + INT( WORK( 1 ) ) + LWKOPT = MAX( 2*N, LWKOPT ) + LWKOPT = MAX( 1, LWKOPT ) + WORK( 1 ) = DBLE( LWKOPT ) + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGSVD3', -INFO ) + RETURN + END IF + IF( LQUERY ) THEN + RETURN + ENDIF +* +* Compute the Frobenius norm of matrices A and B +* + ANORM = DLANGE( '1', M, N, A, LDA, WORK ) + BNORM = DLANGE( '1', P, N, B, LDB, WORK ) +* +* Get machine precision and set up threshold for determining +* the effective numerical rank of the matrices A and B. +* + ULP = DLAMCH( 'Precision' ) + UNFL = DLAMCH( 'Safe Minimum' ) + TOLA = MAX( M, N )*MAX( ANORM, UNFL )*ULP + TOLB = MAX( P, N )*MAX( BNORM, UNFL )*ULP +* +* Preprocessing +* + CALL DGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, + $ TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, WORK, + $ WORK( N+1 ), LWORK-N, INFO ) +* +* Compute the GSVD of two upper "triangular" matrices +* + CALL DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, + $ TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, + $ WORK, NCYCLE, INFO ) +* +* Sort the singular values and store the pivot indices in IWORK +* Copy ALPHA to WORK, then sort ALPHA in WORK +* + CALL DCOPY( N, ALPHA, 1, WORK, 1 ) + IBND = MIN( L, M-K ) + DO 20 I = 1, IBND +* +* Scan for largest ALPHA(K+I) +* + ISUB = I + SMAX = WORK( K+I ) + DO 10 J = I + 1, IBND + TEMP = WORK( K+J ) + IF( TEMP.GT.SMAX ) THEN + ISUB = J + SMAX = TEMP + END IF + 10 CONTINUE + IF( ISUB.NE.I ) THEN + WORK( K+ISUB ) = WORK( K+I ) + WORK( K+I ) = SMAX + IWORK( K+I ) = K + ISUB + ELSE + IWORK( K+I ) = K + I + END IF + 20 CONTINUE +* + WORK( 1 ) = DBLE( LWKOPT ) + RETURN +* +* End of DGGSVD3 +* + END diff --git a/math/lapack/src/main/fortran/dggsvp3.f b/math/lapack/src/main/fortran/dggsvp3.f new file mode 100644 index 0000000000..0ff113b166 --- /dev/null +++ b/math/lapack/src/main/fortran/dggsvp3.f @@ -0,0 +1,571 @@ +*> \brief \b DGGSVP3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGSVP3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, +* TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, +* IWORK, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBQ, JOBU, JOBV +* INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P, LWORK +* DOUBLE PRECISION TOLA, TOLB +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), +* $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGGSVP3 computes orthogonal matrices U, V and Q such that +*> +*> N-K-L K L +*> U**T*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; +*> L ( 0 0 A23 ) +*> M-K-L ( 0 0 0 ) +*> +*> N-K-L K L +*> = K ( 0 A12 A13 ) if M-K-L < 0; +*> M-K ( 0 0 A23 ) +*> +*> N-K-L K L +*> V**T*B*Q = L ( 0 0 B13 ) +*> P-L ( 0 0 0 ) +*> +*> where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular +*> upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, +*> otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective +*> numerical rank of the (M+P)-by-N matrix (A**T,B**T)**T. +*> +*> This decomposition is the preprocessing step for computing the +*> Generalized Singular Value Decomposition (GSVD), see subroutine +*> DGGSVD3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBU +*> \verbatim +*> JOBU is CHARACTER*1 +*> = 'U': Orthogonal matrix U is computed; +*> = 'N': U is not computed. +*> \endverbatim +*> +*> \param[in] JOBV +*> \verbatim +*> JOBV is CHARACTER*1 +*> = 'V': Orthogonal matrix V is computed; +*> = 'N': V is not computed. +*> \endverbatim +*> +*> \param[in] JOBQ +*> \verbatim +*> JOBQ is CHARACTER*1 +*> = 'Q': Orthogonal matrix Q is computed; +*> = 'N': Q is not computed. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows of the matrix B. P >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, A contains the triangular (or trapezoidal) matrix +*> described in the Purpose section. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the P-by-N matrix B. +*> On exit, B contains the triangular matrix described in +*> the Purpose section. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,P). +*> \endverbatim +*> +*> \param[in] TOLA +*> \verbatim +*> TOLA is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] TOLB +*> \verbatim +*> TOLB is DOUBLE PRECISION +*> +*> TOLA and TOLB are the thresholds to determine the effective +*> numerical rank of matrix B and a subblock of A. Generally, +*> they are set to +*> TOLA = MAX(M,N)*norm(A)*MACHEPS, +*> TOLB = MAX(P,N)*norm(B)*MACHEPS. +*> The size of TOLA and TOLB may affect the size of backward +*> errors of the decomposition. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> \endverbatim +*> +*> \param[out] L +*> \verbatim +*> L is INTEGER +*> +*> On exit, K and L specify the dimension of the subblocks +*> described in Purpose section. +*> K + L = effective numerical rank of (A**T,B**T)**T. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension (LDU,M) +*> If JOBU = 'U', U contains the orthogonal matrix U. +*> If JOBU = 'N', U is not referenced. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of the array U. LDU >= max(1,M) if +*> JOBU = 'U'; LDU >= 1 otherwise. +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,P) +*> If JOBV = 'V', V contains the orthogonal matrix V. +*> If JOBV = 'N', V is not referenced. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. LDV >= max(1,P) if +*> JOBV = 'V'; LDV >= 1 otherwise. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ,N) +*> If JOBQ = 'Q', Q contains the orthogonal matrix Q. +*> If JOBQ = 'N', Q is not referenced. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= max(1,N) if +*> JOBQ = 'Q'; LDQ >= 1 otherwise. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date August 2015 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The subroutine uses LAPACK subroutine DGEQP3 for the QR factorization +*> with column pivoting to detect the effective numerical rank of the +*> a matrix. It may be replaced by a better rank determination strategy. +*> +*> DGGSVP3 replaces the deprecated subroutine DGGSVP. +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, + $ TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, + $ IWORK, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* August 2015 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER JOBQ, JOBU, JOBV + INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P, + $ LWORK + DOUBLE PRECISION TOLA, TOLB +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), + $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL FORWRD, WANTQ, WANTU, WANTV, LQUERY + INTEGER I, J, LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEQP3, DGEQR2, DGERQ2, DLACPY, DLAPMT, + $ DLASET, DORG2R, DORM2R, DORMR2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + WANTU = LSAME( JOBU, 'U' ) + WANTV = LSAME( JOBV, 'V' ) + WANTQ = LSAME( JOBQ, 'Q' ) + FORWRD = .TRUE. + LQUERY = ( LWORK.EQ.-1 ) + LWKOPT = 1 +* +* Test the input arguments +* + INFO = 0 + IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN + INFO = -16 + ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN + INFO = -18 + ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN + INFO = -20 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -24 + END IF +* +* Compute workspace +* + IF( INFO.EQ.0 ) THEN + CALL DGEQP3( P, N, B, LDB, IWORK, TAU, WORK, -1, INFO ) + LWKOPT = INT( WORK ( 1 ) ) + IF( WANTV ) THEN + LWKOPT = MAX( LWKOPT, P ) + END IF + LWKOPT = MAX( LWKOPT, MIN( N, P ) ) + LWKOPT = MAX( LWKOPT, M ) + IF( WANTQ ) THEN + LWKOPT = MAX( LWKOPT, N ) + END IF + CALL DGEQP3( M, N, A, LDA, IWORK, TAU, WORK, -1, INFO ) + LWKOPT = MAX( LWKOPT, INT( WORK ( 1 ) ) ) + LWKOPT = MAX( 1, LWKOPT ) + WORK( 1 ) = DBLE( LWKOPT ) + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGSVP3', -INFO ) + RETURN + END IF + IF( LQUERY ) THEN + RETURN + ENDIF +* +* QR with column pivoting of B: B*P = V*( S11 S12 ) +* ( 0 0 ) +* + DO 10 I = 1, N + IWORK( I ) = 0 + 10 CONTINUE + CALL DGEQP3( P, N, B, LDB, IWORK, TAU, WORK, LWORK, INFO ) +* +* Update A := A*P +* + CALL DLAPMT( FORWRD, M, N, A, LDA, IWORK ) +* +* Determine the effective rank of matrix B. +* + L = 0 + DO 20 I = 1, MIN( P, N ) + IF( ABS( B( I, I ) ).GT.TOLB ) + $ L = L + 1 + 20 CONTINUE +* + IF( WANTV ) THEN +* +* Copy the details of V, and form V. +* + CALL DLASET( 'Full', P, P, ZERO, ZERO, V, LDV ) + IF( P.GT.1 ) + $ CALL DLACPY( 'Lower', P-1, N, B( 2, 1 ), LDB, V( 2, 1 ), + $ LDV ) + CALL DORG2R( P, P, MIN( P, N ), V, LDV, TAU, WORK, INFO ) + END IF +* +* Clean up B +* + DO 40 J = 1, L - 1 + DO 30 I = J + 1, L + B( I, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + IF( P.GT.L ) + $ CALL DLASET( 'Full', P-L, N, ZERO, ZERO, B( L+1, 1 ), LDB ) +* + IF( WANTQ ) THEN +* +* Set Q = I and Update Q := Q*P +* + CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) + CALL DLAPMT( FORWRD, N, N, Q, LDQ, IWORK ) + END IF +* + IF( P.GE.L .AND. N.NE.L ) THEN +* +* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z +* + CALL DGERQ2( L, N, B, LDB, TAU, WORK, INFO ) +* +* Update A := A*Z**T +* + CALL DORMR2( 'Right', 'Transpose', M, N, L, B, LDB, TAU, A, + $ LDA, WORK, INFO ) +* + IF( WANTQ ) THEN +* +* Update Q := Q*Z**T +* + CALL DORMR2( 'Right', 'Transpose', N, N, L, B, LDB, TAU, Q, + $ LDQ, WORK, INFO ) + END IF +* +* Clean up B +* + CALL DLASET( 'Full', L, N-L, ZERO, ZERO, B, LDB ) + DO 60 J = N - L + 1, N + DO 50 I = J - N + L + 1, L + B( I, J ) = ZERO + 50 CONTINUE + 60 CONTINUE +* + END IF +* +* Let N-L L +* A = ( A11 A12 ) M, +* +* then the following does the complete QR decomposition of A11: +* +* A11 = U*( 0 T12 )*P1**T +* ( 0 0 ) +* + DO 70 I = 1, N - L + IWORK( I ) = 0 + 70 CONTINUE + CALL DGEQP3( M, N-L, A, LDA, IWORK, TAU, WORK, LWORK, INFO ) +* +* Determine the effective rank of A11 +* + K = 0 + DO 80 I = 1, MIN( M, N-L ) + IF( ABS( A( I, I ) ).GT.TOLA ) + $ K = K + 1 + 80 CONTINUE +* +* Update A12 := U**T*A12, where A12 = A( 1:M, N-L+1:N ) +* + CALL DORM2R( 'Left', 'Transpose', M, L, MIN( M, N-L ), A, LDA, + $ TAU, A( 1, N-L+1 ), LDA, WORK, INFO ) +* + IF( WANTU ) THEN +* +* Copy the details of U, and form U +* + CALL DLASET( 'Full', M, M, ZERO, ZERO, U, LDU ) + IF( M.GT.1 ) + $ CALL DLACPY( 'Lower', M-1, N-L, A( 2, 1 ), LDA, U( 2, 1 ), + $ LDU ) + CALL DORG2R( M, M, MIN( M, N-L ), U, LDU, TAU, WORK, INFO ) + END IF +* + IF( WANTQ ) THEN +* +* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 +* + CALL DLAPMT( FORWRD, N, N-L, Q, LDQ, IWORK ) + END IF +* +* Clean up A: set the strictly lower triangular part of +* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. +* + DO 100 J = 1, K - 1 + DO 90 I = J + 1, K + A( I, J ) = ZERO + 90 CONTINUE + 100 CONTINUE + IF( M.GT.K ) + $ CALL DLASET( 'Full', M-K, N-L, ZERO, ZERO, A( K+1, 1 ), LDA ) +* + IF( N-L.GT.K ) THEN +* +* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 +* + CALL DGERQ2( K, N-L, A, LDA, TAU, WORK, INFO ) +* + IF( WANTQ ) THEN +* +* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1**T +* + CALL DORMR2( 'Right', 'Transpose', N, N-L, K, A, LDA, TAU, + $ Q, LDQ, WORK, INFO ) + END IF +* +* Clean up A +* + CALL DLASET( 'Full', K, N-L-K, ZERO, ZERO, A, LDA ) + DO 120 J = N - L - K + 1, N - L + DO 110 I = J - N + L + K + 1, K + A( I, J ) = ZERO + 110 CONTINUE + 120 CONTINUE +* + END IF +* + IF( M.GT.K ) THEN +* +* QR factorization of A( K+1:M,N-L+1:N ) +* + CALL DGEQR2( M-K, L, A( K+1, N-L+1 ), LDA, TAU, WORK, INFO ) +* + IF( WANTU ) THEN +* +* Update U(:,K+1:M) := U(:,K+1:M)*U1 +* + CALL DORM2R( 'Right', 'No transpose', M, M-K, MIN( M-K, L ), + $ A( K+1, N-L+1 ), LDA, TAU, U( 1, K+1 ), LDU, + $ WORK, INFO ) + END IF +* +* Clean up +* + DO 140 J = N - L + 1, N + DO 130 I = J - N + K + L + 1, M + A( I, J ) = ZERO + 130 CONTINUE + 140 CONTINUE +* + END IF +* + WORK( 1 ) = DBLE( LWKOPT ) + RETURN +* +* End of DGGSVP3 +* + END diff --git a/math/lapack/src/main/fortran/dgsvj0.f b/math/lapack/src/main/fortran/dgsvj0.f new file mode 100644 index 0000000000..7d242806bc --- /dev/null +++ b/math/lapack/src/main/fortran/dgsvj0.f @@ -0,0 +1,1078 @@ +*> \brief \b DGSVJ0 pre-processor for the routine dgesvj. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGSVJ0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, +* SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP +* DOUBLE PRECISION EPS, SFMIN, TOL +* CHARACTER*1 JOBV +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), SVA( N ), D( N ), V( LDV, * ), +* $ WORK( LWORK ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGSVJ0 is called from DGESVJ as a pre-processor and that is its main +*> purpose. It applies Jacobi rotations in the same way as DGESVJ does, but +*> it does not check convergence (stopping criterion). Few tuning +*> parameters (marked by [TP]) are available for the implementer. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBV +*> \verbatim +*> JOBV is CHARACTER*1 +*> Specifies whether the output from this procedure is used +*> to compute the matrix V: +*> = 'V': the product of the Jacobi rotations is accumulated +*> by postmulyiplying the N-by-N array V. +*> (See the description of V.) +*> = 'A': the product of the Jacobi rotations is accumulated +*> by postmulyiplying the MV-by-N array V. +*> (See the descriptions of MV and V.) +*> = 'N': the Jacobi rotations are not accumulated. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the input matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the input matrix A. +*> M >= N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, M-by-N matrix A, such that A*diag(D) represents +*> the input matrix. +*> On exit, +*> A_onexit * D_onexit represents the input matrix A*diag(D) +*> post-multiplied by a sequence of Jacobi rotations, where the +*> rotation threshold and the total number of sweeps are given in +*> TOL and NSWEEP, respectively. +*> (See the descriptions of D, TOL and NSWEEP.) +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The array D accumulates the scaling factors from the fast scaled +*> Jacobi rotations. +*> On entry, A*diag(D) represents the input matrix. +*> On exit, A_onexit*diag(D_onexit) represents the input matrix +*> post-multiplied by a sequence of Jacobi rotations, where the +*> rotation threshold and the total number of sweeps are given in +*> TOL and NSWEEP, respectively. +*> (See the descriptions of A, TOL and NSWEEP.) +*> \endverbatim +*> +*> \param[in,out] SVA +*> \verbatim +*> SVA is DOUBLE PRECISION array, dimension (N) +*> On entry, SVA contains the Euclidean norms of the columns of +*> the matrix A*diag(D). +*> On exit, SVA contains the Euclidean norms of the columns of +*> the matrix onexit*diag(D_onexit). +*> \endverbatim +*> +*> \param[in] MV +*> \verbatim +*> MV is INTEGER +*> If JOBV .EQ. 'A', then MV rows of V are post-multipled by a +*> sequence of Jacobi rotations. +*> If JOBV = 'N', then MV is not referenced. +*> \endverbatim +*> +*> \param[in,out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,N) +*> If JOBV .EQ. 'V' then N rows of V are post-multipled by a +*> sequence of Jacobi rotations. +*> If JOBV .EQ. 'A' then MV rows of V are post-multipled by a +*> sequence of Jacobi rotations. +*> If JOBV = 'N', then V is not referenced. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V, LDV >= 1. +*> If JOBV = 'V', LDV .GE. N. +*> If JOBV = 'A', LDV .GE. MV. +*> \endverbatim +*> +*> \param[in] EPS +*> \verbatim +*> EPS is DOUBLE PRECISION +*> EPS = DLAMCH('Epsilon') +*> \endverbatim +*> +*> \param[in] SFMIN +*> \verbatim +*> SFMIN is DOUBLE PRECISION +*> SFMIN = DLAMCH('Safe Minimum') +*> \endverbatim +*> +*> \param[in] TOL +*> \verbatim +*> TOL is DOUBLE PRECISION +*> TOL is the threshold for Jacobi rotations. For a pair +*> A(:,p), A(:,q) of pivot columns, the Jacobi rotation is +*> applied only if DABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL. +*> \endverbatim +*> +*> \param[in] NSWEEP +*> \verbatim +*> NSWEEP is INTEGER +*> NSWEEP is the number of sweeps of Jacobi rotations to be +*> performed. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> LWORK is the dimension of WORK. LWORK .GE. M. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0 : successful exit. +*> < 0 : if INFO = -i, then the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> DGSVJ0 is used just to enable DGESVJ to call a simplified version of +*> itself to work on a submatrix of the original matrix. +*> +*> \par Contributors: +* ================== +*> +*> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +*> +*> \par Bugs, Examples and Comments: +* ================================= +*> +*> Please report all bugs and send interesting test examples and comments to +*> drmac@math.hr. Thank you. +* +* ===================================================================== + SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, + $ SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP + DOUBLE PRECISION EPS, SFMIN, TOL + CHARACTER*1 JOBV +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), SVA( N ), D( N ), V( LDV, * ), + $ WORK( LWORK ) +* .. +* +* ===================================================================== +* +* .. Local Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG, + $ BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS, + $ ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA, + $ THSIGN + INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1, + $ ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, NBL, + $ NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND + LOGICAL APPLV, ROTOK, RSVEC +* .. +* .. Local Arrays .. + DOUBLE PRECISION FASTR( 5 ) +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS, MAX, DBLE, MIN, DSIGN, DSQRT +* .. +* .. External Functions .. + DOUBLE PRECISION DDOT, DNRM2 + INTEGER IDAMAX + LOGICAL LSAME + EXTERNAL IDAMAX, LSAME, DDOT, DNRM2 +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + APPLV = LSAME( JOBV, 'A' ) + RSVEC = LSAME( JOBV, 'V' ) + IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( ( N.LT.0 ) .OR. ( N.GT.M ) ) THEN + INFO = -3 + ELSE IF( LDA.LT.M ) THEN + INFO = -5 + ELSE IF( ( RSVEC.OR.APPLV ) .AND. ( MV.LT.0 ) ) THEN + INFO = -8 + ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. + $ ( APPLV.AND.( LDV.LT.MV ) ) ) THEN + INFO = -10 + ELSE IF( TOL.LE.EPS ) THEN + INFO = -13 + ELSE IF( NSWEEP.LT.0 ) THEN + INFO = -14 + ELSE IF( LWORK.LT.M ) THEN + INFO = -16 + ELSE + INFO = 0 + END IF +* +* #:( + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGSVJ0', -INFO ) + RETURN + END IF +* + IF( RSVEC ) THEN + MVL = N + ELSE IF( APPLV ) THEN + MVL = MV + END IF + RSVEC = RSVEC .OR. APPLV + + ROOTEPS = DSQRT( EPS ) + ROOTSFMIN = DSQRT( SFMIN ) + SMALL = SFMIN / EPS + BIG = ONE / SFMIN + ROOTBIG = ONE / ROOTSFMIN + BIGTHETA = ONE / ROOTEPS + ROOTTOL = DSQRT( TOL ) +* +* -#- Row-cyclic Jacobi SVD algorithm with column pivoting -#- +* + EMPTSW = ( N*( N-1 ) ) / 2 + NOTROT = 0 + FASTR( 1 ) = ZERO +* +* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#- +* + + SWBAND = 0 +*[TP] SWBAND is a tuning parameter. It is meaningful and effective +* if SGESVJ is used as a computational routine in the preconditioned +* Jacobi SVD algorithm SGESVJ. For sweeps i=1:SWBAND the procedure +* ...... + + KBL = MIN( 8, N ) +*[TP] KBL is a tuning parameter that defines the tile size in the +* tiling of the p-q loops of pivot pairs. In general, an optimal +* value of KBL depends on the matrix dimensions and on the +* parameters of the computer's memory. +* + NBL = N / KBL + IF( ( NBL*KBL ).NE.N )NBL = NBL + 1 + + BLSKIP = ( KBL**2 ) + 1 +*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. + + ROWSKIP = MIN( 5, KBL ) +*[TP] ROWSKIP is a tuning parameter. + + LKAHEAD = 1 +*[TP] LKAHEAD is a tuning parameter. + SWBAND = 0 + PSKIPPED = 0 +* + DO 1993 i = 1, NSWEEP +* .. go go go ... +* + MXAAPQ = ZERO + MXSINJ = ZERO + ISWROT = 0 +* + NOTROT = 0 + PSKIPPED = 0 +* + DO 2000 ibr = 1, NBL + + igl = ( ibr-1 )*KBL + 1 +* + DO 1002 ir1 = 0, MIN( LKAHEAD, NBL-ibr ) +* + igl = igl + ir1*KBL +* + DO 2001 p = igl, MIN( igl+KBL-1, N-1 ) + +* .. de Rijk's pivoting + q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1 + IF( p.NE.q ) THEN + CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 ) + IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1, + $ V( 1, q ), 1 ) + TEMP1 = SVA( p ) + SVA( p ) = SVA( q ) + SVA( q ) = TEMP1 + TEMP1 = D( p ) + D( p ) = D( q ) + D( q ) = TEMP1 + END IF +* + IF( ir1.EQ.0 ) THEN +* +* Column norms are periodically updated by explicit +* norm computation. +* Caveat: +* Some BLAS implementations compute DNRM2(M,A(1,p),1) +* as DSQRT(DDOT(M,A(1,p),1,A(1,p),1)), which may result in +* overflow for ||A(:,p)||_2 > DSQRT(overflow_threshold), and +* undeflow for ||A(:,p)||_2 < DSQRT(underflow_threshold). +* Hence, DNRM2 cannot be trusted, not even in the case when +* the true norm is far from the under(over)flow boundaries. +* If properly implemented DNRM2 is available, the IF-THEN-ELSE +* below should read "AAPP = DNRM2( M, A(1,p), 1 ) * D(p)". +* + IF( ( SVA( p ).LT.ROOTBIG ) .AND. + $ ( SVA( p ).GT.ROOTSFMIN ) ) THEN + SVA( p ) = DNRM2( M, A( 1, p ), 1 )*D( p ) + ELSE + TEMP1 = ZERO + AAPP = ONE + CALL DLASSQ( M, A( 1, p ), 1, TEMP1, AAPP ) + SVA( p ) = TEMP1*DSQRT( AAPP )*D( p ) + END IF + AAPP = SVA( p ) + ELSE + AAPP = SVA( p ) + END IF + +* + IF( AAPP.GT.ZERO ) THEN +* + PSKIPPED = 0 +* + DO 2002 q = p + 1, MIN( igl+KBL-1, N ) +* + AAQQ = SVA( q ) + + IF( AAQQ.GT.ZERO ) THEN +* + AAPP0 = AAPP + IF( AAQQ.GE.ONE ) THEN + ROTOK = ( SMALL*AAPP ).LE.AAQQ + IF( AAPP.LT.( BIG / AAQQ ) ) THEN + AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, + $ q ), 1 )*D( p )*D( q ) / AAQQ ) + $ / AAPP + ELSE + CALL DCOPY( M, A( 1, p ), 1, WORK, 1 ) + CALL DLASCL( 'G', 0, 0, AAPP, D( p ), + $ M, 1, WORK, LDA, IERR ) + AAPQ = DDOT( M, WORK, 1, A( 1, q ), + $ 1 )*D( q ) / AAQQ + END IF + ELSE + ROTOK = AAPP.LE.( AAQQ / SMALL ) + IF( AAPP.GT.( SMALL / AAQQ ) ) THEN + AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, + $ q ), 1 )*D( p )*D( q ) / AAQQ ) + $ / AAPP + ELSE + CALL DCOPY( M, A( 1, q ), 1, WORK, 1 ) + CALL DLASCL( 'G', 0, 0, AAQQ, D( q ), + $ M, 1, WORK, LDA, IERR ) + AAPQ = DDOT( M, WORK, 1, A( 1, p ), + $ 1 )*D( p ) / AAPP + END IF + END IF +* + MXAAPQ = MAX( MXAAPQ, DABS( AAPQ ) ) +* +* TO rotate or NOT to rotate, THAT is the question ... +* + IF( DABS( AAPQ ).GT.TOL ) THEN +* +* .. rotate +* ROTATED = ROTATED + ONE +* + IF( ir1.EQ.0 ) THEN + NOTROT = 0 + PSKIPPED = 0 + ISWROT = ISWROT + 1 + END IF +* + IF( ROTOK ) THEN +* + AQOAP = AAQQ / AAPP + APOAQ = AAPP / AAQQ + THETA = -HALF*DABS( AQOAP-APOAQ )/AAPQ +* + IF( DABS( THETA ).GT.BIGTHETA ) THEN +* + T = HALF / THETA + FASTR( 3 ) = T*D( p ) / D( q ) + FASTR( 4 ) = -T*D( q ) / D( p ) + CALL DROTM( M, A( 1, p ), 1, + $ A( 1, q ), 1, FASTR ) + IF( RSVEC )CALL DROTM( MVL, + $ V( 1, p ), 1, + $ V( 1, q ), 1, + $ FASTR ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE+T*APOAQ*AAPQ ) ) + AAPP = AAPP*DSQRT( MAX( ZERO, + $ ONE-T*AQOAP*AAPQ ) ) + MXSINJ = MAX( MXSINJ, DABS( T ) ) +* + ELSE +* +* .. choose correct signum for THETA and rotate +* + THSIGN = -DSIGN( ONE, AAPQ ) + T = ONE / ( THETA+THSIGN* + $ DSQRT( ONE+THETA*THETA ) ) + CS = DSQRT( ONE / ( ONE+T*T ) ) + SN = T*CS +* + MXSINJ = MAX( MXSINJ, DABS( SN ) ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE+T*APOAQ*AAPQ ) ) + AAPP = AAPP*DSQRT( MAX( ZERO, + $ ONE-T*AQOAP*AAPQ ) ) +* + APOAQ = D( p ) / D( q ) + AQOAP = D( q ) / D( p ) + IF( D( p ).GE.ONE ) THEN + IF( D( q ).GE.ONE ) THEN + FASTR( 3 ) = T*APOAQ + FASTR( 4 ) = -T*AQOAP + D( p ) = D( p )*CS + D( q ) = D( q )*CS + CALL DROTM( M, A( 1, p ), 1, + $ A( 1, q ), 1, + $ FASTR ) + IF( RSVEC )CALL DROTM( MVL, + $ V( 1, p ), 1, V( 1, q ), + $ 1, FASTR ) + ELSE + CALL DAXPY( M, -T*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + CALL DAXPY( M, CS*SN*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + D( p ) = D( p )*CS + D( q ) = D( q ) / CS + IF( RSVEC ) THEN + CALL DAXPY( MVL, -T*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + CALL DAXPY( MVL, + $ CS*SN*APOAQ, + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) + END IF + END IF + ELSE + IF( D( q ).GE.ONE ) THEN + CALL DAXPY( M, T*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + CALL DAXPY( M, -CS*SN*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + D( p ) = D( p ) / CS + D( q ) = D( q )*CS + IF( RSVEC ) THEN + CALL DAXPY( MVL, T*APOAQ, + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) + CALL DAXPY( MVL, + $ -CS*SN*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + END IF + ELSE + IF( D( p ).GE.D( q ) ) THEN + CALL DAXPY( M, -T*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + CALL DAXPY( M, CS*SN*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + D( p ) = D( p )*CS + D( q ) = D( q ) / CS + IF( RSVEC ) THEN + CALL DAXPY( MVL, + $ -T*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + CALL DAXPY( MVL, + $ CS*SN*APOAQ, + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) + END IF + ELSE + CALL DAXPY( M, T*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + CALL DAXPY( M, + $ -CS*SN*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + D( p ) = D( p ) / CS + D( q ) = D( q )*CS + IF( RSVEC ) THEN + CALL DAXPY( MVL, + $ T*APOAQ, V( 1, p ), + $ 1, V( 1, q ), 1 ) + CALL DAXPY( MVL, + $ -CS*SN*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + END IF + END IF + END IF + END IF + END IF +* + ELSE +* .. have to use modified Gram-Schmidt like transformation + CALL DCOPY( M, A( 1, p ), 1, WORK, 1 ) + CALL DLASCL( 'G', 0, 0, AAPP, ONE, M, + $ 1, WORK, LDA, IERR ) + CALL DLASCL( 'G', 0, 0, AAQQ, ONE, M, + $ 1, A( 1, q ), LDA, IERR ) + TEMP1 = -AAPQ*D( p ) / D( q ) + CALL DAXPY( M, TEMP1, WORK, 1, + $ A( 1, q ), 1 ) + CALL DLASCL( 'G', 0, 0, ONE, AAQQ, M, + $ 1, A( 1, q ), LDA, IERR ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE-AAPQ*AAPQ ) ) + MXSINJ = MAX( MXSINJ, SFMIN ) + END IF +* END IF ROTOK THEN ... ELSE +* +* In the case of cancellation in updating SVA(q), SVA(p) +* recompute SVA(q), SVA(p). + IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS ) + $ THEN + IF( ( AAQQ.LT.ROOTBIG ) .AND. + $ ( AAQQ.GT.ROOTSFMIN ) ) THEN + SVA( q ) = DNRM2( M, A( 1, q ), 1 )* + $ D( q ) + ELSE + T = ZERO + AAQQ = ONE + CALL DLASSQ( M, A( 1, q ), 1, T, + $ AAQQ ) + SVA( q ) = T*DSQRT( AAQQ )*D( q ) + END IF + END IF + IF( ( AAPP / AAPP0 ).LE.ROOTEPS ) THEN + IF( ( AAPP.LT.ROOTBIG ) .AND. + $ ( AAPP.GT.ROOTSFMIN ) ) THEN + AAPP = DNRM2( M, A( 1, p ), 1 )* + $ D( p ) + ELSE + T = ZERO + AAPP = ONE + CALL DLASSQ( M, A( 1, p ), 1, T, + $ AAPP ) + AAPP = T*DSQRT( AAPP )*D( p ) + END IF + SVA( p ) = AAPP + END IF +* + ELSE +* A(:,p) and A(:,q) already numerically orthogonal + IF( ir1.EQ.0 )NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + END IF + ELSE +* A(:,q) is zero column + IF( ir1.EQ.0 )NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + END IF +* + IF( ( i.LE.SWBAND ) .AND. + $ ( PSKIPPED.GT.ROWSKIP ) ) THEN + IF( ir1.EQ.0 )AAPP = -AAPP + NOTROT = 0 + GO TO 2103 + END IF +* + 2002 CONTINUE +* END q-LOOP +* + 2103 CONTINUE +* bailed out of q-loop + + SVA( p ) = AAPP + + ELSE + SVA( p ) = AAPP + IF( ( ir1.EQ.0 ) .AND. ( AAPP.EQ.ZERO ) ) + $ NOTROT = NOTROT + MIN( igl+KBL-1, N ) - p + END IF +* + 2001 CONTINUE +* end of the p-loop +* end of doing the block ( ibr, ibr ) + 1002 CONTINUE +* end of ir1-loop +* +*........................................................ +* ... go to the off diagonal blocks +* + igl = ( ibr-1 )*KBL + 1 +* + DO 2010 jbc = ibr + 1, NBL +* + jgl = ( jbc-1 )*KBL + 1 +* +* doing the block at ( ibr, jbc ) +* + IJBLSK = 0 + DO 2100 p = igl, MIN( igl+KBL-1, N ) +* + AAPP = SVA( p ) +* + IF( AAPP.GT.ZERO ) THEN +* + PSKIPPED = 0 +* + DO 2200 q = jgl, MIN( jgl+KBL-1, N ) +* + AAQQ = SVA( q ) +* + IF( AAQQ.GT.ZERO ) THEN + AAPP0 = AAPP +* +* -#- M x 2 Jacobi SVD -#- +* +* -#- Safe Gram matrix computation -#- +* + IF( AAQQ.GE.ONE ) THEN + IF( AAPP.GE.AAQQ ) THEN + ROTOK = ( SMALL*AAPP ).LE.AAQQ + ELSE + ROTOK = ( SMALL*AAQQ ).LE.AAPP + END IF + IF( AAPP.LT.( BIG / AAQQ ) ) THEN + AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, + $ q ), 1 )*D( p )*D( q ) / AAQQ ) + $ / AAPP + ELSE + CALL DCOPY( M, A( 1, p ), 1, WORK, 1 ) + CALL DLASCL( 'G', 0, 0, AAPP, D( p ), + $ M, 1, WORK, LDA, IERR ) + AAPQ = DDOT( M, WORK, 1, A( 1, q ), + $ 1 )*D( q ) / AAQQ + END IF + ELSE + IF( AAPP.GE.AAQQ ) THEN + ROTOK = AAPP.LE.( AAQQ / SMALL ) + ELSE + ROTOK = AAQQ.LE.( AAPP / SMALL ) + END IF + IF( AAPP.GT.( SMALL / AAQQ ) ) THEN + AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, + $ q ), 1 )*D( p )*D( q ) / AAQQ ) + $ / AAPP + ELSE + CALL DCOPY( M, A( 1, q ), 1, WORK, 1 ) + CALL DLASCL( 'G', 0, 0, AAQQ, D( q ), + $ M, 1, WORK, LDA, IERR ) + AAPQ = DDOT( M, WORK, 1, A( 1, p ), + $ 1 )*D( p ) / AAPP + END IF + END IF +* + MXAAPQ = MAX( MXAAPQ, DABS( AAPQ ) ) +* +* TO rotate or NOT to rotate, THAT is the question ... +* + IF( DABS( AAPQ ).GT.TOL ) THEN + NOTROT = 0 +* ROTATED = ROTATED + 1 + PSKIPPED = 0 + ISWROT = ISWROT + 1 +* + IF( ROTOK ) THEN +* + AQOAP = AAQQ / AAPP + APOAQ = AAPP / AAQQ + THETA = -HALF*DABS( AQOAP-APOAQ )/AAPQ + IF( AAQQ.GT.AAPP0 )THETA = -THETA +* + IF( DABS( THETA ).GT.BIGTHETA ) THEN + T = HALF / THETA + FASTR( 3 ) = T*D( p ) / D( q ) + FASTR( 4 ) = -T*D( q ) / D( p ) + CALL DROTM( M, A( 1, p ), 1, + $ A( 1, q ), 1, FASTR ) + IF( RSVEC )CALL DROTM( MVL, + $ V( 1, p ), 1, + $ V( 1, q ), 1, + $ FASTR ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE+T*APOAQ*AAPQ ) ) + AAPP = AAPP*DSQRT( MAX( ZERO, + $ ONE-T*AQOAP*AAPQ ) ) + MXSINJ = MAX( MXSINJ, DABS( T ) ) + ELSE +* +* .. choose correct signum for THETA and rotate +* + THSIGN = -DSIGN( ONE, AAPQ ) + IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN + T = ONE / ( THETA+THSIGN* + $ DSQRT( ONE+THETA*THETA ) ) + CS = DSQRT( ONE / ( ONE+T*T ) ) + SN = T*CS + MXSINJ = MAX( MXSINJ, DABS( SN ) ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE+T*APOAQ*AAPQ ) ) + AAPP = AAPP*DSQRT( MAX( ZERO, + $ ONE-T*AQOAP*AAPQ ) ) +* + APOAQ = D( p ) / D( q ) + AQOAP = D( q ) / D( p ) + IF( D( p ).GE.ONE ) THEN +* + IF( D( q ).GE.ONE ) THEN + FASTR( 3 ) = T*APOAQ + FASTR( 4 ) = -T*AQOAP + D( p ) = D( p )*CS + D( q ) = D( q )*CS + CALL DROTM( M, A( 1, p ), 1, + $ A( 1, q ), 1, + $ FASTR ) + IF( RSVEC )CALL DROTM( MVL, + $ V( 1, p ), 1, V( 1, q ), + $ 1, FASTR ) + ELSE + CALL DAXPY( M, -T*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + CALL DAXPY( M, CS*SN*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + IF( RSVEC ) THEN + CALL DAXPY( MVL, -T*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + CALL DAXPY( MVL, + $ CS*SN*APOAQ, + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) + END IF + D( p ) = D( p )*CS + D( q ) = D( q ) / CS + END IF + ELSE + IF( D( q ).GE.ONE ) THEN + CALL DAXPY( M, T*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + CALL DAXPY( M, -CS*SN*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + IF( RSVEC ) THEN + CALL DAXPY( MVL, T*APOAQ, + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) + CALL DAXPY( MVL, + $ -CS*SN*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + END IF + D( p ) = D( p ) / CS + D( q ) = D( q )*CS + ELSE + IF( D( p ).GE.D( q ) ) THEN + CALL DAXPY( M, -T*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + CALL DAXPY( M, CS*SN*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + D( p ) = D( p )*CS + D( q ) = D( q ) / CS + IF( RSVEC ) THEN + CALL DAXPY( MVL, + $ -T*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + CALL DAXPY( MVL, + $ CS*SN*APOAQ, + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) + END IF + ELSE + CALL DAXPY( M, T*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + CALL DAXPY( M, + $ -CS*SN*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + D( p ) = D( p ) / CS + D( q ) = D( q )*CS + IF( RSVEC ) THEN + CALL DAXPY( MVL, + $ T*APOAQ, V( 1, p ), + $ 1, V( 1, q ), 1 ) + CALL DAXPY( MVL, + $ -CS*SN*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + END IF + END IF + END IF + END IF + END IF +* + ELSE + IF( AAPP.GT.AAQQ ) THEN + CALL DCOPY( M, A( 1, p ), 1, WORK, + $ 1 ) + CALL DLASCL( 'G', 0, 0, AAPP, ONE, + $ M, 1, WORK, LDA, IERR ) + CALL DLASCL( 'G', 0, 0, AAQQ, ONE, + $ M, 1, A( 1, q ), LDA, + $ IERR ) + TEMP1 = -AAPQ*D( p ) / D( q ) + CALL DAXPY( M, TEMP1, WORK, 1, + $ A( 1, q ), 1 ) + CALL DLASCL( 'G', 0, 0, ONE, AAQQ, + $ M, 1, A( 1, q ), LDA, + $ IERR ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE-AAPQ*AAPQ ) ) + MXSINJ = MAX( MXSINJ, SFMIN ) + ELSE + CALL DCOPY( M, A( 1, q ), 1, WORK, + $ 1 ) + CALL DLASCL( 'G', 0, 0, AAQQ, ONE, + $ M, 1, WORK, LDA, IERR ) + CALL DLASCL( 'G', 0, 0, AAPP, ONE, + $ M, 1, A( 1, p ), LDA, + $ IERR ) + TEMP1 = -AAPQ*D( q ) / D( p ) + CALL DAXPY( M, TEMP1, WORK, 1, + $ A( 1, p ), 1 ) + CALL DLASCL( 'G', 0, 0, ONE, AAPP, + $ M, 1, A( 1, p ), LDA, + $ IERR ) + SVA( p ) = AAPP*DSQRT( MAX( ZERO, + $ ONE-AAPQ*AAPQ ) ) + MXSINJ = MAX( MXSINJ, SFMIN ) + END IF + END IF +* END IF ROTOK THEN ... ELSE +* +* In the case of cancellation in updating SVA(q) +* .. recompute SVA(q) + IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS ) + $ THEN + IF( ( AAQQ.LT.ROOTBIG ) .AND. + $ ( AAQQ.GT.ROOTSFMIN ) ) THEN + SVA( q ) = DNRM2( M, A( 1, q ), 1 )* + $ D( q ) + ELSE + T = ZERO + AAQQ = ONE + CALL DLASSQ( M, A( 1, q ), 1, T, + $ AAQQ ) + SVA( q ) = T*DSQRT( AAQQ )*D( q ) + END IF + END IF + IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN + IF( ( AAPP.LT.ROOTBIG ) .AND. + $ ( AAPP.GT.ROOTSFMIN ) ) THEN + AAPP = DNRM2( M, A( 1, p ), 1 )* + $ D( p ) + ELSE + T = ZERO + AAPP = ONE + CALL DLASSQ( M, A( 1, p ), 1, T, + $ AAPP ) + AAPP = T*DSQRT( AAPP )*D( p ) + END IF + SVA( p ) = AAPP + END IF +* end of OK rotation + ELSE + NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF + ELSE + NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF +* + IF( ( i.LE.SWBAND ) .AND. ( IJBLSK.GE.BLSKIP ) ) + $ THEN + SVA( p ) = AAPP + NOTROT = 0 + GO TO 2011 + END IF + IF( ( i.LE.SWBAND ) .AND. + $ ( PSKIPPED.GT.ROWSKIP ) ) THEN + AAPP = -AAPP + NOTROT = 0 + GO TO 2203 + END IF +* + 2200 CONTINUE +* end of the q-loop + 2203 CONTINUE +* + SVA( p ) = AAPP +* + ELSE + IF( AAPP.EQ.ZERO )NOTROT = NOTROT + + $ MIN( jgl+KBL-1, N ) - jgl + 1 + IF( AAPP.LT.ZERO )NOTROT = 0 + END IF + + 2100 CONTINUE +* end of the p-loop + 2010 CONTINUE +* end of the jbc-loop + 2011 CONTINUE +*2011 bailed out of the jbc-loop + DO 2012 p = igl, MIN( igl+KBL-1, N ) + SVA( p ) = DABS( SVA( p ) ) + 2012 CONTINUE +* + 2000 CONTINUE +*2000 :: end of the ibr-loop +* +* .. update SVA(N) + IF( ( SVA( N ).LT.ROOTBIG ) .AND. ( SVA( N ).GT.ROOTSFMIN ) ) + $ THEN + SVA( N ) = DNRM2( M, A( 1, N ), 1 )*D( N ) + ELSE + T = ZERO + AAPP = ONE + CALL DLASSQ( M, A( 1, N ), 1, T, AAPP ) + SVA( N ) = T*DSQRT( AAPP )*D( N ) + END IF +* +* Additional steering devices +* + IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. + $ ( ISWROT.LE.N ) ) )SWBAND = i +* + IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.DBLE( N )*TOL ) .AND. + $ ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN + GO TO 1994 + END IF +* + IF( NOTROT.GE.EMPTSW )GO TO 1994 + + 1993 CONTINUE +* end i=1:NSWEEP loop +* #:) Reaching this point means that the procedure has comleted the given +* number of iterations. + INFO = NSWEEP - 1 + GO TO 1995 + 1994 CONTINUE +* #:) Reaching this point means that during the i-th sweep all pivots were +* below the given tolerance, causing early exit. +* + INFO = 0 +* #:) INFO = 0 confirms successful iterations. + 1995 CONTINUE +* +* Sort the vector D. + DO 5991 p = 1, N - 1 + q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1 + IF( p.NE.q ) THEN + TEMP1 = SVA( p ) + SVA( p ) = SVA( q ) + SVA( q ) = TEMP1 + TEMP1 = D( p ) + D( p ) = D( q ) + D( q ) = TEMP1 + CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 ) + IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1, V( 1, q ), 1 ) + END IF + 5991 CONTINUE +* + RETURN +* .. +* .. END OF DGSVJ0 +* .. + END diff --git a/math/lapack/src/main/fortran/dgsvj1.f b/math/lapack/src/main/fortran/dgsvj1.f new file mode 100644 index 0000000000..9acab16ba7 --- /dev/null +++ b/math/lapack/src/main/fortran/dgsvj1.f @@ -0,0 +1,783 @@ +*> \brief \b DGSVJ1 pre-processor for the routine dgesvj, applies Jacobi rotations targeting only particular pivots. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGSVJ1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, +* EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION EPS, SFMIN, TOL +* INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP +* CHARACTER*1 JOBV +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), D( N ), SVA( N ), V( LDV, * ), +* $ WORK( LWORK ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGSVJ1 is called from DGESVJ as a pre-processor and that is its main +*> purpose. It applies Jacobi rotations in the same way as DGESVJ does, but +*> it targets only particular pivots and it does not check convergence +*> (stopping criterion). Few tunning parameters (marked by [TP]) are +*> available for the implementer. +*> +*> Further Details +*> ~~~~~~~~~~~~~~~ +*> DGSVJ1 applies few sweeps of Jacobi rotations in the column space of +*> the input M-by-N matrix A. The pivot pairs are taken from the (1,2) +*> off-diagonal block in the corresponding N-by-N Gram matrix A^T * A. The +*> block-entries (tiles) of the (1,2) off-diagonal block are marked by the +*> [x]'s in the following scheme: +*> +*> | * * * [x] [x] [x]| +*> | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks. +*> | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block. +*> |[x] [x] [x] * * * | +*> |[x] [x] [x] * * * | +*> |[x] [x] [x] * * * | +*> +*> In terms of the columns of A, the first N1 columns are rotated 'against' +*> the remaining N-N1 columns, trying to increase the angle between the +*> corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is +*> tiled using quadratic tiles of side KBL. Here, KBL is a tunning parmeter. +*> The number of sweeps is given in NSWEEP and the orthogonality threshold +*> is given in TOL. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBV +*> \verbatim +*> JOBV is CHARACTER*1 +*> Specifies whether the output from this procedure is used +*> to compute the matrix V: +*> = 'V': the product of the Jacobi rotations is accumulated +*> by postmulyiplying the N-by-N array V. +*> (See the description of V.) +*> = 'A': the product of the Jacobi rotations is accumulated +*> by postmulyiplying the MV-by-N array V. +*> (See the descriptions of MV and V.) +*> = 'N': the Jacobi rotations are not accumulated. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the input matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the input matrix A. +*> M >= N >= 0. +*> \endverbatim +*> +*> \param[in] N1 +*> \verbatim +*> N1 is INTEGER +*> N1 specifies the 2 x 2 block partition, the first N1 columns are +*> rotated 'against' the remaining N-N1 columns of A. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, M-by-N matrix A, such that A*diag(D) represents +*> the input matrix. +*> On exit, +*> A_onexit * D_onexit represents the input matrix A*diag(D) +*> post-multiplied by a sequence of Jacobi rotations, where the +*> rotation threshold and the total number of sweeps are given in +*> TOL and NSWEEP, respectively. +*> (See the descriptions of N1, D, TOL and NSWEEP.) +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The array D accumulates the scaling factors from the fast scaled +*> Jacobi rotations. +*> On entry, A*diag(D) represents the input matrix. +*> On exit, A_onexit*diag(D_onexit) represents the input matrix +*> post-multiplied by a sequence of Jacobi rotations, where the +*> rotation threshold and the total number of sweeps are given in +*> TOL and NSWEEP, respectively. +*> (See the descriptions of N1, A, TOL and NSWEEP.) +*> \endverbatim +*> +*> \param[in,out] SVA +*> \verbatim +*> SVA is DOUBLE PRECISION array, dimension (N) +*> On entry, SVA contains the Euclidean norms of the columns of +*> the matrix A*diag(D). +*> On exit, SVA contains the Euclidean norms of the columns of +*> the matrix onexit*diag(D_onexit). +*> \endverbatim +*> +*> \param[in] MV +*> \verbatim +*> MV is INTEGER +*> If JOBV .EQ. 'A', then MV rows of V are post-multipled by a +*> sequence of Jacobi rotations. +*> If JOBV = 'N', then MV is not referenced. +*> \endverbatim +*> +*> \param[in,out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,N) +*> If JOBV .EQ. 'V' then N rows of V are post-multipled by a +*> sequence of Jacobi rotations. +*> If JOBV .EQ. 'A' then MV rows of V are post-multipled by a +*> sequence of Jacobi rotations. +*> If JOBV = 'N', then V is not referenced. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V, LDV >= 1. +*> If JOBV = 'V', LDV .GE. N. +*> If JOBV = 'A', LDV .GE. MV. +*> \endverbatim +*> +*> \param[in] EPS +*> \verbatim +*> EPS is DOUBLE PRECISION +*> EPS = DLAMCH('Epsilon') +*> \endverbatim +*> +*> \param[in] SFMIN +*> \verbatim +*> SFMIN is DOUBLE PRECISION +*> SFMIN = DLAMCH('Safe Minimum') +*> \endverbatim +*> +*> \param[in] TOL +*> \verbatim +*> TOL is DOUBLE PRECISION +*> TOL is the threshold for Jacobi rotations. For a pair +*> A(:,p), A(:,q) of pivot columns, the Jacobi rotation is +*> applied only if DABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL. +*> \endverbatim +*> +*> \param[in] NSWEEP +*> \verbatim +*> NSWEEP is INTEGER +*> NSWEEP is the number of sweeps of Jacobi rotations to be +*> performed. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> LWORK is the dimension of WORK. LWORK .GE. M. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0 : successful exit. +*> < 0 : if INFO = -i, then the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +* +* ===================================================================== + SUBROUTINE DGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, + $ EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, SFMIN, TOL + INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP + CHARACTER*1 JOBV +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( N ), SVA( N ), V( LDV, * ), + $ WORK( LWORK ) +* .. +* +* ===================================================================== +* +* .. Local Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG, + $ BIGTHETA, CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG, + $ ROOTEPS, ROOTSFMIN, ROOTTOL, SMALL, SN, T, + $ TEMP1, THETA, THSIGN + INTEGER BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK, + $ ISWROT, jbc, jgl, KBL, MVL, NOTROT, nblc, nblr, + $ p, PSKIPPED, q, ROWSKIP, SWBAND + LOGICAL APPLV, ROTOK, RSVEC +* .. +* .. Local Arrays .. + DOUBLE PRECISION FASTR( 5 ) +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS, MAX, DBLE, MIN, DSIGN, DSQRT +* .. +* .. External Functions .. + DOUBLE PRECISION DDOT, DNRM2 + INTEGER IDAMAX + LOGICAL LSAME + EXTERNAL IDAMAX, LSAME, DDOT, DNRM2 +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + APPLV = LSAME( JOBV, 'A' ) + RSVEC = LSAME( JOBV, 'V' ) + IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( ( N.LT.0 ) .OR. ( N.GT.M ) ) THEN + INFO = -3 + ELSE IF( N1.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.M ) THEN + INFO = -6 + ELSE IF( ( RSVEC.OR.APPLV ) .AND. ( MV.LT.0 ) ) THEN + INFO = -9 + ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. + $ ( APPLV.AND.( LDV.LT.MV ) ) ) THEN + INFO = -11 + ELSE IF( TOL.LE.EPS ) THEN + INFO = -14 + ELSE IF( NSWEEP.LT.0 ) THEN + INFO = -15 + ELSE IF( LWORK.LT.M ) THEN + INFO = -17 + ELSE + INFO = 0 + END IF +* +* #:( + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGSVJ1', -INFO ) + RETURN + END IF +* + IF( RSVEC ) THEN + MVL = N + ELSE IF( APPLV ) THEN + MVL = MV + END IF + RSVEC = RSVEC .OR. APPLV + + ROOTEPS = DSQRT( EPS ) + ROOTSFMIN = DSQRT( SFMIN ) + SMALL = SFMIN / EPS + BIG = ONE / SFMIN + ROOTBIG = ONE / ROOTSFMIN + LARGE = BIG / DSQRT( DBLE( M*N ) ) + BIGTHETA = ONE / ROOTEPS + ROOTTOL = DSQRT( TOL ) +* +* .. Initialize the right singular vector matrix .. +* +* RSVEC = LSAME( JOBV, 'Y' ) +* + EMPTSW = N1*( N-N1 ) + NOTROT = 0 + FASTR( 1 ) = ZERO +* +* .. Row-cyclic pivot strategy with de Rijk's pivoting .. +* + KBL = MIN( 8, N ) + NBLR = N1 / KBL + IF( ( NBLR*KBL ).NE.N1 )NBLR = NBLR + 1 + +* .. the tiling is nblr-by-nblc [tiles] + + NBLC = ( N-N1 ) / KBL + IF( ( NBLC*KBL ).NE.( N-N1 ) )NBLC = NBLC + 1 + BLSKIP = ( KBL**2 ) + 1 +*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. + + ROWSKIP = MIN( 5, KBL ) +*[TP] ROWSKIP is a tuning parameter. + SWBAND = 0 +*[TP] SWBAND is a tuning parameter. It is meaningful and effective +* if SGESVJ is used as a computational routine in the preconditioned +* Jacobi SVD algorithm SGESVJ. +* +* +* | * * * [x] [x] [x]| +* | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks. +* | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block. +* |[x] [x] [x] * * * | +* |[x] [x] [x] * * * | +* |[x] [x] [x] * * * | +* +* + DO 1993 i = 1, NSWEEP +* .. go go go ... +* + MXAAPQ = ZERO + MXSINJ = ZERO + ISWROT = 0 +* + NOTROT = 0 + PSKIPPED = 0 +* + DO 2000 ibr = 1, NBLR + + igl = ( ibr-1 )*KBL + 1 +* +* +*........................................................ +* ... go to the off diagonal blocks + + igl = ( ibr-1 )*KBL + 1 + + DO 2010 jbc = 1, NBLC + + jgl = N1 + ( jbc-1 )*KBL + 1 + +* doing the block at ( ibr, jbc ) + + IJBLSK = 0 + DO 2100 p = igl, MIN( igl+KBL-1, N1 ) + + AAPP = SVA( p ) + + IF( AAPP.GT.ZERO ) THEN + + PSKIPPED = 0 + + DO 2200 q = jgl, MIN( jgl+KBL-1, N ) +* + AAQQ = SVA( q ) + + IF( AAQQ.GT.ZERO ) THEN + AAPP0 = AAPP +* +* .. M x 2 Jacobi SVD .. +* +* .. Safe Gram matrix computation .. +* + IF( AAQQ.GE.ONE ) THEN + IF( AAPP.GE.AAQQ ) THEN + ROTOK = ( SMALL*AAPP ).LE.AAQQ + ELSE + ROTOK = ( SMALL*AAQQ ).LE.AAPP + END IF + IF( AAPP.LT.( BIG / AAQQ ) ) THEN + AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, + $ q ), 1 )*D( p )*D( q ) / AAQQ ) + $ / AAPP + ELSE + CALL DCOPY( M, A( 1, p ), 1, WORK, 1 ) + CALL DLASCL( 'G', 0, 0, AAPP, D( p ), + $ M, 1, WORK, LDA, IERR ) + AAPQ = DDOT( M, WORK, 1, A( 1, q ), + $ 1 )*D( q ) / AAQQ + END IF + ELSE + IF( AAPP.GE.AAQQ ) THEN + ROTOK = AAPP.LE.( AAQQ / SMALL ) + ELSE + ROTOK = AAQQ.LE.( AAPP / SMALL ) + END IF + IF( AAPP.GT.( SMALL / AAQQ ) ) THEN + AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, + $ q ), 1 )*D( p )*D( q ) / AAQQ ) + $ / AAPP + ELSE + CALL DCOPY( M, A( 1, q ), 1, WORK, 1 ) + CALL DLASCL( 'G', 0, 0, AAQQ, D( q ), + $ M, 1, WORK, LDA, IERR ) + AAPQ = DDOT( M, WORK, 1, A( 1, p ), + $ 1 )*D( p ) / AAPP + END IF + END IF + + MXAAPQ = MAX( MXAAPQ, DABS( AAPQ ) ) + +* TO rotate or NOT to rotate, THAT is the question ... +* + IF( DABS( AAPQ ).GT.TOL ) THEN + NOTROT = 0 +* ROTATED = ROTATED + 1 + PSKIPPED = 0 + ISWROT = ISWROT + 1 +* + IF( ROTOK ) THEN +* + AQOAP = AAQQ / AAPP + APOAQ = AAPP / AAQQ + THETA = -HALF*DABS(AQOAP-APOAQ) / AAPQ + IF( AAQQ.GT.AAPP0 )THETA = -THETA + + IF( DABS( THETA ).GT.BIGTHETA ) THEN + T = HALF / THETA + FASTR( 3 ) = T*D( p ) / D( q ) + FASTR( 4 ) = -T*D( q ) / D( p ) + CALL DROTM( M, A( 1, p ), 1, + $ A( 1, q ), 1, FASTR ) + IF( RSVEC )CALL DROTM( MVL, + $ V( 1, p ), 1, + $ V( 1, q ), 1, + $ FASTR ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE+T*APOAQ*AAPQ ) ) + AAPP = AAPP*DSQRT( MAX( ZERO, + $ ONE-T*AQOAP*AAPQ ) ) + MXSINJ = MAX( MXSINJ, DABS( T ) ) + ELSE +* +* .. choose correct signum for THETA and rotate +* + THSIGN = -DSIGN( ONE, AAPQ ) + IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN + T = ONE / ( THETA+THSIGN* + $ DSQRT( ONE+THETA*THETA ) ) + CS = DSQRT( ONE / ( ONE+T*T ) ) + SN = T*CS + MXSINJ = MAX( MXSINJ, DABS( SN ) ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE+T*APOAQ*AAPQ ) ) + AAPP = AAPP*DSQRT( MAX( ZERO, + $ ONE-T*AQOAP*AAPQ ) ) + + APOAQ = D( p ) / D( q ) + AQOAP = D( q ) / D( p ) + IF( D( p ).GE.ONE ) THEN +* + IF( D( q ).GE.ONE ) THEN + FASTR( 3 ) = T*APOAQ + FASTR( 4 ) = -T*AQOAP + D( p ) = D( p )*CS + D( q ) = D( q )*CS + CALL DROTM( M, A( 1, p ), 1, + $ A( 1, q ), 1, + $ FASTR ) + IF( RSVEC )CALL DROTM( MVL, + $ V( 1, p ), 1, V( 1, q ), + $ 1, FASTR ) + ELSE + CALL DAXPY( M, -T*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + CALL DAXPY( M, CS*SN*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + IF( RSVEC ) THEN + CALL DAXPY( MVL, -T*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + CALL DAXPY( MVL, + $ CS*SN*APOAQ, + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) + END IF + D( p ) = D( p )*CS + D( q ) = D( q ) / CS + END IF + ELSE + IF( D( q ).GE.ONE ) THEN + CALL DAXPY( M, T*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + CALL DAXPY( M, -CS*SN*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + IF( RSVEC ) THEN + CALL DAXPY( MVL, T*APOAQ, + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) + CALL DAXPY( MVL, + $ -CS*SN*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + END IF + D( p ) = D( p ) / CS + D( q ) = D( q )*CS + ELSE + IF( D( p ).GE.D( q ) ) THEN + CALL DAXPY( M, -T*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + CALL DAXPY( M, CS*SN*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + D( p ) = D( p )*CS + D( q ) = D( q ) / CS + IF( RSVEC ) THEN + CALL DAXPY( MVL, + $ -T*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + CALL DAXPY( MVL, + $ CS*SN*APOAQ, + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) + END IF + ELSE + CALL DAXPY( M, T*APOAQ, + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) + CALL DAXPY( M, + $ -CS*SN*AQOAP, + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) + D( p ) = D( p ) / CS + D( q ) = D( q )*CS + IF( RSVEC ) THEN + CALL DAXPY( MVL, + $ T*APOAQ, V( 1, p ), + $ 1, V( 1, q ), 1 ) + CALL DAXPY( MVL, + $ -CS*SN*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) + END IF + END IF + END IF + END IF + END IF + + ELSE + IF( AAPP.GT.AAQQ ) THEN + CALL DCOPY( M, A( 1, p ), 1, WORK, + $ 1 ) + CALL DLASCL( 'G', 0, 0, AAPP, ONE, + $ M, 1, WORK, LDA, IERR ) + CALL DLASCL( 'G', 0, 0, AAQQ, ONE, + $ M, 1, A( 1, q ), LDA, + $ IERR ) + TEMP1 = -AAPQ*D( p ) / D( q ) + CALL DAXPY( M, TEMP1, WORK, 1, + $ A( 1, q ), 1 ) + CALL DLASCL( 'G', 0, 0, ONE, AAQQ, + $ M, 1, A( 1, q ), LDA, + $ IERR ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE-AAPQ*AAPQ ) ) + MXSINJ = MAX( MXSINJ, SFMIN ) + ELSE + CALL DCOPY( M, A( 1, q ), 1, WORK, + $ 1 ) + CALL DLASCL( 'G', 0, 0, AAQQ, ONE, + $ M, 1, WORK, LDA, IERR ) + CALL DLASCL( 'G', 0, 0, AAPP, ONE, + $ M, 1, A( 1, p ), LDA, + $ IERR ) + TEMP1 = -AAPQ*D( q ) / D( p ) + CALL DAXPY( M, TEMP1, WORK, 1, + $ A( 1, p ), 1 ) + CALL DLASCL( 'G', 0, 0, ONE, AAPP, + $ M, 1, A( 1, p ), LDA, + $ IERR ) + SVA( p ) = AAPP*DSQRT( MAX( ZERO, + $ ONE-AAPQ*AAPQ ) ) + MXSINJ = MAX( MXSINJ, SFMIN ) + END IF + END IF +* END IF ROTOK THEN ... ELSE +* +* In the case of cancellation in updating SVA(q) +* .. recompute SVA(q) + IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS ) + $ THEN + IF( ( AAQQ.LT.ROOTBIG ) .AND. + $ ( AAQQ.GT.ROOTSFMIN ) ) THEN + SVA( q ) = DNRM2( M, A( 1, q ), 1 )* + $ D( q ) + ELSE + T = ZERO + AAQQ = ONE + CALL DLASSQ( M, A( 1, q ), 1, T, + $ AAQQ ) + SVA( q ) = T*DSQRT( AAQQ )*D( q ) + END IF + END IF + IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN + IF( ( AAPP.LT.ROOTBIG ) .AND. + $ ( AAPP.GT.ROOTSFMIN ) ) THEN + AAPP = DNRM2( M, A( 1, p ), 1 )* + $ D( p ) + ELSE + T = ZERO + AAPP = ONE + CALL DLASSQ( M, A( 1, p ), 1, T, + $ AAPP ) + AAPP = T*DSQRT( AAPP )*D( p ) + END IF + SVA( p ) = AAPP + END IF +* end of OK rotation + ELSE + NOTROT = NOTROT + 1 +* SKIPPED = SKIPPED + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF + ELSE + NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF + +* IF ( NOTROT .GE. EMPTSW ) GO TO 2011 + IF( ( i.LE.SWBAND ) .AND. ( IJBLSK.GE.BLSKIP ) ) + $ THEN + SVA( p ) = AAPP + NOTROT = 0 + GO TO 2011 + END IF + IF( ( i.LE.SWBAND ) .AND. + $ ( PSKIPPED.GT.ROWSKIP ) ) THEN + AAPP = -AAPP + NOTROT = 0 + GO TO 2203 + END IF + +* + 2200 CONTINUE +* end of the q-loop + 2203 CONTINUE + + SVA( p ) = AAPP +* + ELSE + IF( AAPP.EQ.ZERO )NOTROT = NOTROT + + $ MIN( jgl+KBL-1, N ) - jgl + 1 + IF( AAPP.LT.ZERO )NOTROT = 0 +*** IF ( NOTROT .GE. EMPTSW ) GO TO 2011 + END IF + + 2100 CONTINUE +* end of the p-loop + 2010 CONTINUE +* end of the jbc-loop + 2011 CONTINUE +*2011 bailed out of the jbc-loop + DO 2012 p = igl, MIN( igl+KBL-1, N ) + SVA( p ) = DABS( SVA( p ) ) + 2012 CONTINUE +*** IF ( NOTROT .GE. EMPTSW ) GO TO 1994 + 2000 CONTINUE +*2000 :: end of the ibr-loop +* +* .. update SVA(N) + IF( ( SVA( N ).LT.ROOTBIG ) .AND. ( SVA( N ).GT.ROOTSFMIN ) ) + $ THEN + SVA( N ) = DNRM2( M, A( 1, N ), 1 )*D( N ) + ELSE + T = ZERO + AAPP = ONE + CALL DLASSQ( M, A( 1, N ), 1, T, AAPP ) + SVA( N ) = T*DSQRT( AAPP )*D( N ) + END IF +* +* Additional steering devices +* + IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. + $ ( ISWROT.LE.N ) ) )SWBAND = i + + IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.DBLE( N )*TOL ) .AND. + $ ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN + GO TO 1994 + END IF + +* + IF( NOTROT.GE.EMPTSW )GO TO 1994 + + 1993 CONTINUE +* end i=1:NSWEEP loop +* #:) Reaching this point means that the procedure has completed the given +* number of sweeps. + INFO = NSWEEP - 1 + GO TO 1995 + 1994 CONTINUE +* #:) Reaching this point means that during the i-th sweep all pivots were +* below the given threshold, causing early exit. + + INFO = 0 +* #:) INFO = 0 confirms successful iterations. + 1995 CONTINUE +* +* Sort the vector D +* + DO 5991 p = 1, N - 1 + q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1 + IF( p.NE.q ) THEN + TEMP1 = SVA( p ) + SVA( p ) = SVA( q ) + SVA( q ) = TEMP1 + TEMP1 = D( p ) + D( p ) = D( q ) + D( q ) = TEMP1 + CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 ) + IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1, V( 1, q ), 1 ) + END IF + 5991 CONTINUE +* + RETURN +* .. +* .. END OF DGSVJ1 +* .. + END diff --git a/math/lapack/src/main/fortran/dgtcon.f b/math/lapack/src/main/fortran/dgtcon.f new file mode 100644 index 0000000000..4271823489 --- /dev/null +++ b/math/lapack/src/main/fortran/dgtcon.f @@ -0,0 +1,255 @@ +*> \brief \b DGTCON +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGTCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER NORM +* INTEGER INFO, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGTCON estimates the reciprocal of the condition number of a real +*> tridiagonal matrix A using the LU factorization as computed by +*> DGTTRF. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] DL +*> \verbatim +*> DL is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) multipliers that define the matrix L from the +*> LU factorization of A as computed by DGTTRF. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of the upper triangular matrix U from +*> the LU factorization of A. +*> \endverbatim +*> +*> \param[in] DU +*> \verbatim +*> DU is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) elements of the first superdiagonal of U. +*> \endverbatim +*> +*> \param[in] DU2 +*> \verbatim +*> DU2 is DOUBLE PRECISION array, dimension (N-2) +*> The (n-2) elements of the second superdiagonal of U. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices; for 1 <= i <= n, row i of the matrix was +*> interchanged with row IPIV(i). IPIV(i) will always be either +*> i or i+1; IPIV(i) = i indicates a row interchange was not +*> required. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is 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. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGTcomputational +* +* ===================================================================== + SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, + $ WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER INFO, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ONENRM + INTEGER I, KASE, KASE1 + DOUBLE PRECISION AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGTTRS, DLACN2, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments. +* + 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( ANORM.LT.ZERO ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGTCON', -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 +* +* Check that D(1:N) is non-zero. +* + DO 10 I = 1, N + IF( D( I ).EQ.ZERO ) + $ RETURN + 10 CONTINUE +* + AINVNM = ZERO + IF( ONENRM ) THEN + KASE1 = 1 + ELSE + KASE1 = 2 + END IF + KASE = 0 + 20 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(U)*inv(L). +* + CALL DGTTRS( 'No transpose', N, 1, DL, D, DU, DU2, IPIV, + $ WORK, N, INFO ) + ELSE +* +* Multiply by inv(L**T)*inv(U**T). +* + CALL DGTTRS( 'Transpose', N, 1, DL, D, DU, DU2, IPIV, WORK, + $ N, INFO ) + END IF + GO TO 20 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + RETURN +* +* End of DGTCON +* + END diff --git a/math/lapack/src/main/fortran/dgtrfs.f b/math/lapack/src/main/fortran/dgtrfs.f new file mode 100644 index 0000000000..74889353f2 --- /dev/null +++ b/math/lapack/src/main/fortran/dgtrfs.f @@ -0,0 +1,474 @@ +*> \brief \b DGTRFS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGTRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, +* IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* INTEGER INFO, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), +* $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), +* $ FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGTRFS improves the computed solution to a system of linear +*> equations when the coefficient matrix is tridiagonal, and provides +*> error bounds and backward error estimates for the solution. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] DL +*> \verbatim +*> DL is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) subdiagonal elements of A. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of A. +*> \endverbatim +*> +*> \param[in] DU +*> \verbatim +*> DU is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) superdiagonal elements of A. +*> \endverbatim +*> +*> \param[in] DLF +*> \verbatim +*> DLF is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) multipliers that define the matrix L from the +*> LU factorization of A as computed by DGTTRF. +*> \endverbatim +*> +*> \param[in] DF +*> \verbatim +*> DF is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of the upper triangular matrix U from +*> the LU factorization of A. +*> \endverbatim +*> +*> \param[in] DUF +*> \verbatim +*> DUF is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) elements of the first superdiagonal of U. +*> \endverbatim +*> +*> \param[in] DU2 +*> \verbatim +*> DU2 is DOUBLE PRECISION array, dimension (N-2) +*> The (n-2) elements of the second superdiagonal of U. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices; for 1 <= i <= n, row i of the matrix was +*> interchanged with row IPIV(i). IPIV(i) will always be either +*> i or i+1; IPIV(i) = i indicates a row interchange was not +*> required. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> On entry, the solution matrix X, as computed by DGTTRS. +*> On exit, the improved solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> ITMAX is the maximum number of steps of iterative refinement. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGTcomputational +* +* ===================================================================== + SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, + $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), + $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), + $ FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER ITMAX + PARAMETER ( ITMAX = 5 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, 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 TRANSN, TRANST + INTEGER COUNT, I, J, KASE, NZ + DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGTTRS, DLACN2, DLAGTM, 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( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGTRFS', -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 + TRANSN = 'N' + TRANST = 'T' + ELSE + TRANSN = 'T' + TRANST = 'N' + END IF +* +* NZ = maximum number of nonzero elements in each row of A, plus 1 +* + NZ = 4 + EPS = DLAMCH( 'Epsilon' ) + SAFMIN = DLAMCH( 'Safe minimum' ) + SAFE1 = NZ*SAFMIN + SAFE2 = SAFE1 / EPS +* +* Do for each right hand side +* + DO 110 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 DLAGTM( TRANS, N, 1, -ONE, DL, D, DU, X( 1, J ), LDX, ONE, + $ WORK( N+1 ), N ) +* +* Compute abs(op(A))*abs(x) + abs(b) for use in the backward +* error bound. +* + IF( NOTRAN ) THEN + IF( N.EQ.1 ) THEN + WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) + ELSE + WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) + + $ ABS( DU( 1 )*X( 2, J ) ) + DO 30 I = 2, N - 1 + WORK( I ) = ABS( B( I, J ) ) + + $ ABS( DL( I-1 )*X( I-1, J ) ) + + $ ABS( D( I )*X( I, J ) ) + + $ ABS( DU( I )*X( I+1, J ) ) + 30 CONTINUE + WORK( N ) = ABS( B( N, J ) ) + + $ ABS( DL( N-1 )*X( N-1, J ) ) + + $ ABS( D( N )*X( N, J ) ) + END IF + ELSE + IF( N.EQ.1 ) THEN + WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) + ELSE + WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) + + $ ABS( DL( 1 )*X( 2, J ) ) + DO 40 I = 2, N - 1 + WORK( I ) = ABS( B( I, J ) ) + + $ ABS( DU( I-1 )*X( I-1, J ) ) + + $ ABS( D( I )*X( I, J ) ) + + $ ABS( DL( I )*X( I+1, J ) ) + 40 CONTINUE + WORK( N ) = ABS( B( N, J ) ) + + $ ABS( DU( N-1 )*X( N-1, J ) ) + + $ ABS( D( N )*X( N, J ) ) + END IF + END IF +* +* Compute componentwise relative backward error from formula +* +* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) +* +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. If the i-th component of the denominator is less +* than SAFE2, then SAFE1 is added to the i-th components of the +* numerator and denominator before dividing. +* + S = ZERO + DO 50 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 + 50 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 DGTTRS( TRANS, N, 1, DLF, DF, DUF, DU2, 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 60 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 + 60 CONTINUE +* + KASE = 0 + 70 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 DGTTRS( TRANST, N, 1, DLF, DF, DUF, DU2, IPIV, + $ WORK( N+1 ), N, INFO ) + DO 80 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 80 CONTINUE + ELSE +* +* Multiply by inv(op(A))*diag(W). +* + DO 90 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 90 CONTINUE + CALL DGTTRS( TRANSN, N, 1, DLF, DF, DUF, DU2, IPIV, + $ WORK( N+1 ), N, INFO ) + END IF + GO TO 70 + END IF +* +* Normalize error. +* + LSTRES = ZERO + DO 100 I = 1, N + LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) + 100 CONTINUE + IF( LSTRES.NE.ZERO ) + $ FERR( J ) = FERR( J ) / LSTRES +* + 110 CONTINUE +* + RETURN +* +* End of DGTRFS +* + END diff --git a/math/lapack/src/main/fortran/dgtsv.f b/math/lapack/src/main/fortran/dgtsv.f new file mode 100644 index 0000000000..b683eaafb6 --- /dev/null +++ b/math/lapack/src/main/fortran/dgtsv.f @@ -0,0 +1,333 @@ +*> \brief DGTSV computes the solution to system of linear equations A * X = B for GT matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGTSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGTSV solves the equation +*> +*> A*X = B, +*> +*> where A is an n by n tridiagonal matrix, by Gaussian elimination with +*> partial pivoting. +*> +*> Note that the equation A**T*X = B may be solved by interchanging the +*> order of the arguments DU and DL. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] DL +*> \verbatim +*> DL is DOUBLE PRECISION array, dimension (N-1) +*> On entry, DL must contain the (n-1) sub-diagonal elements of +*> A. +*> +*> On exit, DL is overwritten by the (n-2) elements of the +*> second super-diagonal of the upper triangular matrix U from +*> the LU factorization of A, in DL(1), ..., DL(n-2). +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, D must contain the diagonal elements of A. +*> +*> On exit, D is overwritten by the n diagonal elements of U. +*> \endverbatim +*> +*> \param[in,out] DU +*> \verbatim +*> DU is DOUBLE PRECISION array, dimension (N-1) +*> On entry, DU must contain the (n-1) super-diagonal elements +*> of A. +*> +*> On exit, DU is overwritten by the (n-1) elements of the first +*> super-diagonal of U. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, U(i,i) is exactly zero, and the solution +*> has not been computed. The factorization has not been +*> completed unless i = N. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGTsolve +* +* ===================================================================== + SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION FACT, TEMP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -2 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGTSV ', -INFO ) + RETURN + END IF +* + IF( N.EQ.0 ) + $ RETURN +* + IF( NRHS.EQ.1 ) THEN + DO 10 I = 1, N - 2 + IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN +* +* No row interchange required +* + IF( D( I ).NE.ZERO ) THEN + FACT = DL( I ) / D( I ) + D( I+1 ) = D( I+1 ) - FACT*DU( I ) + B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 ) + ELSE + INFO = I + RETURN + END IF + DL( I ) = ZERO + ELSE +* +* Interchange rows I and I+1 +* + FACT = D( I ) / DL( I ) + D( I ) = DL( I ) + TEMP = D( I+1 ) + D( I+1 ) = DU( I ) - FACT*TEMP + DL( I ) = DU( I+1 ) + DU( I+1 ) = -FACT*DL( I ) + DU( I ) = TEMP + TEMP = B( I, 1 ) + B( I, 1 ) = B( I+1, 1 ) + B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 ) + END IF + 10 CONTINUE + IF( N.GT.1 ) THEN + I = N - 1 + IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN + IF( D( I ).NE.ZERO ) THEN + FACT = DL( I ) / D( I ) + D( I+1 ) = D( I+1 ) - FACT*DU( I ) + B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 ) + ELSE + INFO = I + RETURN + END IF + ELSE + FACT = D( I ) / DL( I ) + D( I ) = DL( I ) + TEMP = D( I+1 ) + D( I+1 ) = DU( I ) - FACT*TEMP + DU( I ) = TEMP + TEMP = B( I, 1 ) + B( I, 1 ) = B( I+1, 1 ) + B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 ) + END IF + END IF + IF( D( N ).EQ.ZERO ) THEN + INFO = N + RETURN + END IF + ELSE + DO 40 I = 1, N - 2 + IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN +* +* No row interchange required +* + IF( D( I ).NE.ZERO ) THEN + FACT = DL( I ) / D( I ) + D( I+1 ) = D( I+1 ) - FACT*DU( I ) + DO 20 J = 1, NRHS + B( I+1, J ) = B( I+1, J ) - FACT*B( I, J ) + 20 CONTINUE + ELSE + INFO = I + RETURN + END IF + DL( I ) = ZERO + ELSE +* +* Interchange rows I and I+1 +* + FACT = D( I ) / DL( I ) + D( I ) = DL( I ) + TEMP = D( I+1 ) + D( I+1 ) = DU( I ) - FACT*TEMP + DL( I ) = DU( I+1 ) + DU( I+1 ) = -FACT*DL( I ) + DU( I ) = TEMP + DO 30 J = 1, NRHS + TEMP = B( I, J ) + B( I, J ) = B( I+1, J ) + B( I+1, J ) = TEMP - FACT*B( I+1, J ) + 30 CONTINUE + END IF + 40 CONTINUE + IF( N.GT.1 ) THEN + I = N - 1 + IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN + IF( D( I ).NE.ZERO ) THEN + FACT = DL( I ) / D( I ) + D( I+1 ) = D( I+1 ) - FACT*DU( I ) + DO 50 J = 1, NRHS + B( I+1, J ) = B( I+1, J ) - FACT*B( I, J ) + 50 CONTINUE + ELSE + INFO = I + RETURN + END IF + ELSE + FACT = D( I ) / DL( I ) + D( I ) = DL( I ) + TEMP = D( I+1 ) + D( I+1 ) = DU( I ) - FACT*TEMP + DU( I ) = TEMP + DO 60 J = 1, NRHS + TEMP = B( I, J ) + B( I, J ) = B( I+1, J ) + B( I+1, J ) = TEMP - FACT*B( I+1, J ) + 60 CONTINUE + END IF + END IF + IF( D( N ).EQ.ZERO ) THEN + INFO = N + RETURN + END IF + END IF +* +* Back solve with the matrix U from the factorization. +* + IF( NRHS.LE.2 ) THEN + J = 1 + 70 CONTINUE + B( N, J ) = B( N, J ) / D( N ) + IF( N.GT.1 ) + $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 ) + DO 80 I = N - 2, 1, -1 + B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )* + $ B( I+2, J ) ) / D( I ) + 80 CONTINUE + IF( J.LT.NRHS ) THEN + J = J + 1 + GO TO 70 + END IF + ELSE + DO 100 J = 1, NRHS + B( N, J ) = B( N, J ) / D( N ) + IF( N.GT.1 ) + $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / + $ D( N-1 ) + DO 90 I = N - 2, 1, -1 + B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )* + $ B( I+2, J ) ) / D( I ) + 90 CONTINUE + 100 CONTINUE + END IF +* + RETURN +* +* End of DGTSV +* + END diff --git a/math/lapack/src/main/fortran/dgtsvx.f b/math/lapack/src/main/fortran/dgtsvx.f new file mode 100644 index 0000000000..92bc9eac3c --- /dev/null +++ b/math/lapack/src/main/fortran/dgtsvx.f @@ -0,0 +1,414 @@ +*> \brief DGTSVX computes the solution to system of linear equations A * X = B for GT matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGTSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, +* DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER FACT, TRANS +* INTEGER INFO, LDB, LDX, N, NRHS +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), +* $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), +* $ FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGTSVX uses the LU factorization to compute the solution to a real +*> system of linear equations A * X = B or A**T * X = B, +*> where A is a tridiagonal matrix of order N and X and B are N-by-NRHS +*> matrices. +*> +*> Error bounds on the solution and a condition estimate are also +*> provided. +*> \endverbatim +* +*> \par Description: +* ================= +*> +*> \verbatim +*> +*> The following steps are performed: +*> +*> 1. If FACT = 'N', the LU decomposition is used to factor the matrix A +*> as A = L * U, where L is a product of permutation and unit lower +*> bidiagonal matrices and U is upper triangular with nonzeros in +*> only the main diagonal and first two superdiagonals. +*> +*> 2. If some U(i,i)=0, so that U is exactly singular, then the routine +*> returns with INFO = i. Otherwise, the factored form of A is used +*> to estimate the condition number of the matrix A. If the +*> reciprocal of the condition number is less than machine precision, +*> INFO = N+1 is returned as a warning, but the routine still goes on +*> to solve for X and compute error bounds as described below. +*> +*> 3. The system of equations is solved for X using the factored form +*> of A. +*> +*> 4. Iterative refinement is applied to improve the computed solution +*> matrix and calculate error bounds and backward error estimates +*> for it. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> Specifies whether or not the factored form of A has been +*> supplied on entry. +*> = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored +*> form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV +*> will not be modified. +*> = 'N': The matrix will be copied to DLF, DF, and DUF +*> and factored. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] DL +*> \verbatim +*> DL is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) subdiagonal elements of A. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of A. +*> \endverbatim +*> +*> \param[in] DU +*> \verbatim +*> DU is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) superdiagonal elements of A. +*> \endverbatim +*> +*> \param[in,out] DLF +*> \verbatim +*> DLF is DOUBLE PRECISION array, dimension (N-1) +*> If FACT = 'F', then DLF is an input argument and on entry +*> contains the (n-1) multipliers that define the matrix L from +*> the LU factorization of A as computed by DGTTRF. +*> +*> If FACT = 'N', then DLF is an output argument and on exit +*> contains the (n-1) multipliers that define the matrix L from +*> the LU factorization of A. +*> \endverbatim +*> +*> \param[in,out] DF +*> \verbatim +*> DF is DOUBLE PRECISION array, dimension (N) +*> If FACT = 'F', then DF is an input argument and on entry +*> contains the n diagonal elements of the upper triangular +*> matrix U from the LU factorization of A. +*> +*> If FACT = 'N', then DF is an output argument and on exit +*> contains the n diagonal elements of the upper triangular +*> matrix U from the LU factorization of A. +*> \endverbatim +*> +*> \param[in,out] DUF +*> \verbatim +*> DUF is DOUBLE PRECISION array, dimension (N-1) +*> If FACT = 'F', then DUF is an input argument and on entry +*> contains the (n-1) elements of the first superdiagonal of U. +*> +*> If FACT = 'N', then DUF is an output argument and on exit +*> contains the (n-1) elements of the first superdiagonal of U. +*> \endverbatim +*> +*> \param[in,out] DU2 +*> \verbatim +*> DU2 is DOUBLE PRECISION array, dimension (N-2) +*> If FACT = 'F', then DU2 is an input argument and on entry +*> contains the (n-2) elements of the second superdiagonal of +*> U. +*> +*> If FACT = 'N', then DU2 is an output argument and on exit +*> contains the (n-2) elements of the second superdiagonal of +*> U. +*> \endverbatim +*> +*> \param[in,out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> If FACT = 'F', then IPIV is an input argument and on entry +*> contains the pivot indices from the LU factorization of A as +*> computed by DGTTRF. +*> +*> If FACT = 'N', then IPIV is an output argument and on exit +*> contains the pivot indices from the LU factorization of A; +*> row i of the matrix was interchanged with row IPIV(i). +*> IPIV(i) will always be either i or i+1; IPIV(i) = i indicates +*> a row interchange was not required. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The N-by-NRHS right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The estimate of the reciprocal condition number of the matrix +*> A. If RCOND is less than the machine precision (in +*> particular, if RCOND = 0), the matrix is singular to working +*> precision. This condition is indicated by a return code of +*> INFO > 0. +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, and i is +*> <= N: U(i,i) is exactly zero. The factorization +*> has not been completed unless i = N, but the +*> factor U is exactly singular, so the solution +*> and error bounds could not be computed. +*> RCOND = 0 is returned. +*> = N+1: U is nonsingular, but RCOND is less than machine +*> precision, meaning that the matrix is singular +*> to working precision. Nevertheless, the +*> solution and error bounds are computed because +*> there are a number of situations where the +*> computed solution can be more accurate than the +*> value of RCOND would suggest. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGTsolve +* +* ===================================================================== + SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, + $ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, + $ WORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER FACT, TRANS + INTEGER INFO, LDB, LDX, N, NRHS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), + $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), + $ FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOFACT, NOTRAN + CHARACTER NORM + DOUBLE PRECISION ANORM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGT + EXTERNAL LSAME, DLAMCH, DLANGT +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGTCON, DGTRFS, DGTTRF, DGTTRS, DLACPY, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOFACT .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( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGTSVX', -INFO ) + RETURN + END IF +* + IF( NOFACT ) THEN +* +* Compute the LU factorization of A. +* + CALL DCOPY( N, D, 1, DF, 1 ) + IF( N.GT.1 ) THEN + CALL DCOPY( N-1, DL, 1, DLF, 1 ) + CALL DCOPY( N-1, DU, 1, DUF, 1 ) + END IF + CALL DGTTRF( N, DLF, DF, DUF, DU2, IPIV, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 )THEN + RCOND = ZERO + RETURN + END IF + END IF +* +* Compute the norm of the matrix A. +* + IF( NOTRAN ) THEN + NORM = '1' + ELSE + NORM = 'I' + END IF + ANORM = DLANGT( NORM, N, DL, D, DU ) +* +* Compute the reciprocal of the condition number of A. +* + CALL DGTCON( NORM, N, DLF, DF, DUF, DU2, IPIV, ANORM, RCOND, WORK, + $ IWORK, INFO ) +* +* Compute the solution vectors X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DGTTRS( TRANS, N, NRHS, DLF, DF, DUF, DU2, IPIV, X, LDX, + $ INFO ) +* +* Use iterative refinement to improve the computed solutions and +* compute error bounds and backward error estimates for them. +* + CALL DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, + $ B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* Set INFO = N+1 if the matrix is singular to working precision. +* + IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) + $ INFO = N + 1 +* + RETURN +* +* End of DGTSVX +* + END diff --git a/math/lapack/src/main/fortran/dgttrf.f b/math/lapack/src/main/fortran/dgttrf.f new file mode 100644 index 0000000000..3c9808fdb4 --- /dev/null +++ b/math/lapack/src/main/fortran/dgttrf.f @@ -0,0 +1,237 @@ +*> \brief \b DGTTRF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGTTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGTTRF computes an LU factorization of a real tridiagonal matrix A +*> using elimination with partial pivoting and row interchanges. +*> +*> The factorization has the form +*> A = L * U +*> where L is a product of permutation and unit lower bidiagonal +*> matrices and U is upper triangular with nonzeros in only the main +*> diagonal and first two superdiagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. +*> \endverbatim +*> +*> \param[in,out] DL +*> \verbatim +*> DL is DOUBLE PRECISION array, dimension (N-1) +*> On entry, DL must contain the (n-1) sub-diagonal elements of +*> A. +*> +*> On exit, DL is overwritten by the (n-1) multipliers that +*> define the matrix L from the LU factorization of A. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, D must contain the diagonal elements of A. +*> +*> On exit, D is overwritten by the n diagonal elements of the +*> upper triangular matrix U from the LU factorization of A. +*> \endverbatim +*> +*> \param[in,out] DU +*> \verbatim +*> DU is DOUBLE PRECISION array, dimension (N-1) +*> On entry, DU must contain the (n-1) super-diagonal elements +*> of A. +*> +*> On exit, DU is overwritten by the (n-1) elements of the first +*> super-diagonal of U. +*> \endverbatim +*> +*> \param[out] DU2 +*> \verbatim +*> DU2 is DOUBLE PRECISION array, dimension (N-2) +*> On exit, DU2 is overwritten by the (n-2) elements of the +*> second super-diagonal of U. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices; for 1 <= i <= n, row i of the matrix was +*> interchanged with row IPIV(i). IPIV(i) will always be either +*> i or i+1; IPIV(i) = i indicates a row interchange was not +*> required. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> > 0: if INFO = k, 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGTcomputational +* +* ===================================================================== + SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION FACT, TEMP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + CALL XERBLA( 'DGTTRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Initialize IPIV(i) = i and DU2(I) = 0 +* + DO 10 I = 1, N + IPIV( I ) = I + 10 CONTINUE + DO 20 I = 1, N - 2 + DU2( I ) = ZERO + 20 CONTINUE +* + DO 30 I = 1, N - 2 + IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN +* +* No row interchange required, eliminate DL(I) +* + IF( D( I ).NE.ZERO ) THEN + FACT = DL( I ) / D( I ) + DL( I ) = FACT + D( I+1 ) = D( I+1 ) - FACT*DU( I ) + END IF + ELSE +* +* Interchange rows I and I+1, eliminate DL(I) +* + FACT = D( I ) / DL( I ) + D( I ) = DL( I ) + DL( I ) = FACT + TEMP = DU( I ) + DU( I ) = D( I+1 ) + D( I+1 ) = TEMP - FACT*D( I+1 ) + DU2( I ) = DU( I+1 ) + DU( I+1 ) = -FACT*DU( I+1 ) + IPIV( I ) = I + 1 + END IF + 30 CONTINUE + IF( N.GT.1 ) THEN + I = N - 1 + IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN + IF( D( I ).NE.ZERO ) THEN + FACT = DL( I ) / D( I ) + DL( I ) = FACT + D( I+1 ) = D( I+1 ) - FACT*DU( I ) + END IF + ELSE + FACT = D( I ) / DL( I ) + D( I ) = DL( I ) + DL( I ) = FACT + TEMP = DU( I ) + DU( I ) = D( I+1 ) + D( I+1 ) = TEMP - FACT*D( I+1 ) + IPIV( I ) = I + 1 + END IF + END IF +* +* Check for a zero on the diagonal of U. +* + DO 40 I = 1, N + IF( D( I ).EQ.ZERO ) THEN + INFO = I + GO TO 50 + END IF + 40 CONTINUE + 50 CONTINUE +* + RETURN +* +* End of DGTTRF +* + END diff --git a/math/lapack/src/main/fortran/dgttrs.f b/math/lapack/src/main/fortran/dgttrs.f new file mode 100644 index 0000000000..3bbeb1d1dd --- /dev/null +++ b/math/lapack/src/main/fortran/dgttrs.f @@ -0,0 +1,223 @@ +*> \brief \b DGTTRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGTTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGTTRS solves one of the systems of equations +*> A*X = B or A**T*X = B, +*> with a tridiagonal matrix A using the LU factorization computed +*> by DGTTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the form of the system of equations. +*> = 'N': A * X = B (No transpose) +*> = 'T': A**T* X = B (Transpose) +*> = 'C': A**T* X = B (Conjugate transpose = Transpose) +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] DL +*> \verbatim +*> DL is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) multipliers that define the matrix L from the +*> LU factorization of A. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of the upper triangular matrix U from +*> the LU factorization of A. +*> \endverbatim +*> +*> \param[in] DU +*> \verbatim +*> DU is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) elements of the first super-diagonal of U. +*> \endverbatim +*> +*> \param[in] DU2 +*> \verbatim +*> DU2 is DOUBLE PRECISION array, dimension (N-2) +*> The (n-2) elements of the second super-diagonal of U. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices; for 1 <= i <= n, row i of the matrix was +*> interchanged with row IPIV(i). IPIV(i) will always be either +*> i or i+1; IPIV(i) = i indicates a row interchange was not +*> required. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the matrix of right hand side vectors B. +*> On exit, B is overwritten by the solution vectors X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGTcomputational +* +* ===================================================================== + SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL NOTRAN + INTEGER ITRANS, J, JB, NB +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DGTTS2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' ) + IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ. + $ 't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGTTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* +* Decode TRANS +* + IF( NOTRAN ) THEN + ITRANS = 0 + ELSE + ITRANS = 1 + END IF +* +* Determine the number of right-hand sides to solve at a time. +* + IF( NRHS.EQ.1 ) THEN + NB = 1 + ELSE + NB = MAX( 1, ILAENV( 1, 'DGTTRS', TRANS, N, NRHS, -1, -1 ) ) + END IF +* + IF( NB.GE.NRHS ) THEN + CALL DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) + ELSE + DO 10 J = 1, NRHS, NB + JB = MIN( NRHS-J+1, NB ) + CALL DGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ), + $ LDB ) + 10 CONTINUE + END IF +* +* End of DGTTRS +* + END diff --git a/math/lapack/src/main/fortran/dgtts2.f b/math/lapack/src/main/fortran/dgtts2.f new file mode 100644 index 0000000000..39e7b0075c --- /dev/null +++ b/math/lapack/src/main/fortran/dgtts2.f @@ -0,0 +1,274 @@ +*> \brief \b DGTTS2 solves a system of linear equations with a tridiagonal matrix using the LU factorization computed by sgttrf. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGTTS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) +* +* .. Scalar Arguments .. +* INTEGER ITRANS, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGTTS2 solves one of the systems of equations +*> A*X = B or A**T*X = B, +*> with a tridiagonal matrix A using the LU factorization computed +*> by DGTTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITRANS +*> \verbatim +*> ITRANS is INTEGER +*> Specifies the form of the system of equations. +*> = 0: A * X = B (No transpose) +*> = 1: A**T* X = B (Transpose) +*> = 2: A**T* X = B (Conjugate transpose = Transpose) +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] DL +*> \verbatim +*> DL is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) multipliers that define the matrix L from the +*> LU factorization of A. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of the upper triangular matrix U from +*> the LU factorization of A. +*> \endverbatim +*> +*> \param[in] DU +*> \verbatim +*> DU is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) elements of the first super-diagonal of U. +*> \endverbatim +*> +*> \param[in] DU2 +*> \verbatim +*> DU2 is DOUBLE PRECISION array, dimension (N-2) +*> The (n-2) elements of the second super-diagonal of U. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices; for 1 <= i <= n, row i of the matrix was +*> interchanged with row IPIV(i). IPIV(i) will always be either +*> i or i+1; IPIV(i) = i indicates a row interchange was not +*> required. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the matrix of right hand side vectors B. +*> On exit, B is overwritten by the solution vectors X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGTcomputational +* +* ===================================================================== + SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER ITRANS, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IP, J + DOUBLE PRECISION TEMP +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( ITRANS.EQ.0 ) THEN +* +* Solve A*X = B using the LU factorization of A, +* overwriting each right hand side vector with its solution. +* + IF( NRHS.LE.1 ) THEN + J = 1 + 10 CONTINUE +* +* Solve L*x = b. +* + DO 20 I = 1, N - 1 + IP = IPIV( I ) + TEMP = B( I+1-IP+I, J ) - DL( I )*B( IP, J ) + B( I, J ) = B( IP, J ) + B( I+1, J ) = TEMP + 20 CONTINUE +* +* Solve U*x = b. +* + B( N, J ) = B( N, J ) / D( N ) + IF( N.GT.1 ) + $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / + $ D( N-1 ) + DO 30 I = N - 2, 1, -1 + B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* + $ B( I+2, J ) ) / D( I ) + 30 CONTINUE + IF( J.LT.NRHS ) THEN + J = J + 1 + GO TO 10 + END IF + ELSE + DO 60 J = 1, NRHS +* +* Solve L*x = b. +* + DO 40 I = 1, N - 1 + IF( IPIV( I ).EQ.I ) THEN + B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) + ELSE + TEMP = B( I, J ) + B( I, J ) = B( I+1, J ) + B( I+1, J ) = TEMP - DL( I )*B( I, J ) + END IF + 40 CONTINUE +* +* Solve U*x = b. +* + B( N, J ) = B( N, J ) / D( N ) + IF( N.GT.1 ) + $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / + $ D( N-1 ) + DO 50 I = N - 2, 1, -1 + B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* + $ B( I+2, J ) ) / D( I ) + 50 CONTINUE + 60 CONTINUE + END IF + ELSE +* +* Solve A**T * X = B. +* + IF( NRHS.LE.1 ) THEN +* +* Solve U**T*x = b. +* + J = 1 + 70 CONTINUE + B( 1, J ) = B( 1, J ) / D( 1 ) + IF( N.GT.1 ) + $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) + DO 80 I = 3, N + B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )* + $ B( I-2, J ) ) / D( I ) + 80 CONTINUE +* +* Solve L**T*x = b. +* + DO 90 I = N - 1, 1, -1 + IP = IPIV( I ) + TEMP = B( I, J ) - DL( I )*B( I+1, J ) + B( I, J ) = B( IP, J ) + B( IP, J ) = TEMP + 90 CONTINUE + IF( J.LT.NRHS ) THEN + J = J + 1 + GO TO 70 + END IF +* + ELSE + DO 120 J = 1, NRHS +* +* Solve U**T*x = b. +* + B( 1, J ) = B( 1, J ) / D( 1 ) + IF( N.GT.1 ) + $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) + DO 100 I = 3, N + B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )- + $ DU2( I-2 )*B( I-2, J ) ) / D( I ) + 100 CONTINUE + DO 110 I = N - 1, 1, -1 + IF( IPIV( I ).EQ.I ) THEN + B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) + ELSE + TEMP = B( I+1, J ) + B( I+1, J ) = B( I, J ) - DL( I )*TEMP + B( I, J ) = TEMP + END IF + 110 CONTINUE + 120 CONTINUE + END IF + END IF +* +* End of DGTTS2 +* + END diff --git a/math/lapack/src/main/fortran/dhgeqz.f b/math/lapack/src/main/fortran/dhgeqz.f new file mode 100644 index 0000000000..99557f20eb --- /dev/null +++ b/math/lapack/src/main/fortran/dhgeqz.f @@ -0,0 +1,1367 @@ +*> \brief \b DHGEQZ +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DHGEQZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, +* ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, +* LWORK, INFO ) +* +* .. 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is CHARACTER*1 +*> = 'E': Compute eigenvalues only; +*> = 'S': Compute eigenvalues and the Schur form. +*> \endverbatim +*> +*> \param[in] COMPQ +*> \verbatim +*> COMPQ is 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. +*> \endverbatim +*> +*> \param[in] COMPZ +*> \verbatim +*> COMPZ is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices H, T, Q, and Z. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is 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. +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is 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. +*> If JOB = 'E', the diagonal blocks of H match those of S, but +*> the rest of H is unspecified. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the array H. LDH >= max( 1, N ). +*> \endverbatim +*> +*> \param[in,out] T +*> \verbatim +*> T is 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. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max( 1, N ). +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is DOUBLE PRECISION array, dimension (N) +*> The real parts of each scalar alpha defining an eigenvalue +*> of GNEP. +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is 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). +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is 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. +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ, N) +*> On entry, if COMPQ = 'V', the orthogonal matrix Q1 used in +*> the reduction of (A,B) to generalized Hessenberg form. +*> On exit, if COMPQ = 'I', the orthogonal matrix of left Schur +*> vectors of (H,T), and if COMPQ = 'V', the orthogonal matrix +*> of left Schur vectors of (A,B). +*> Not referenced if COMPQ = 'N'. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= 1. +*> If COMPQ='V' or 'I', then LDQ >= N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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'. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1. +*> If COMPZ='V' or 'I', then LDZ >= N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, + $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, + $ LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. 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, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dhsein.f b/math/lapack/src/main/fortran/dhsein.f new file mode 100644 index 0000000000..e71cdc87e1 --- /dev/null +++ b/math/lapack/src/main/fortran/dhsein.f @@ -0,0 +1,530 @@ +*> \brief \b DHSEIN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DHSEIN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, +* VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, +* IFAILR, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER EIGSRC, INITV, SIDE +* INTEGER INFO, LDH, LDVL, LDVR, M, MM, N +* .. +* .. Array Arguments .. +* LOGICAL SELECT( * ) +* INTEGER IFAILL( * ), IFAILR( * ) +* DOUBLE PRECISION H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ), +* $ WI( * ), WORK( * ), WR( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DHSEIN uses inverse iteration to find specified right and/or left +*> eigenvectors of a real upper Hessenberg matrix H. +*> +*> The right eigenvector x and the left eigenvector y of the matrix H +*> corresponding to an eigenvalue w are defined by: +*> +*> H * x = w * x, y**h * H = w * y**h +*> +*> where y**h denotes the conjugate transpose of the vector y. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'R': compute right eigenvectors only; +*> = 'L': compute left eigenvectors only; +*> = 'B': compute both right and left eigenvectors. +*> \endverbatim +*> +*> \param[in] EIGSRC +*> \verbatim +*> EIGSRC is CHARACTER*1 +*> Specifies the source of eigenvalues supplied in (WR,WI): +*> = 'Q': the eigenvalues were found using DHSEQR; thus, if +*> H has zero subdiagonal elements, and so is +*> block-triangular, then the j-th eigenvalue can be +*> assumed to be an eigenvalue of the block containing +*> the j-th row/column. This property allows DHSEIN to +*> perform inverse iteration on just one diagonal block. +*> = 'N': no assumptions are made on the correspondence +*> between eigenvalues and diagonal blocks. In this +*> case, DHSEIN must always perform inverse iteration +*> using the whole matrix H. +*> \endverbatim +*> +*> \param[in] INITV +*> \verbatim +*> INITV is CHARACTER*1 +*> = 'N': no initial vectors are supplied; +*> = 'U': user-supplied initial vectors are stored in the arrays +*> VL and/or VR. +*> \endverbatim +*> +*> \param[in,out] SELECT +*> \verbatim +*> SELECT is LOGICAL array, dimension (N) +*> Specifies the eigenvectors to be computed. To select the +*> real eigenvector corresponding to a real eigenvalue WR(j), +*> SELECT(j) must be set to .TRUE.. To select the complex +*> eigenvector corresponding to a complex eigenvalue +*> (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)), +*> either SELECT(j) or SELECT(j+1) or both must be set to +*> .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is +*> .FALSE.. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H. N >= 0. +*> \endverbatim +*> +*> \param[in] H +*> \verbatim +*> H is DOUBLE PRECISION array, dimension (LDH,N) +*> The upper Hessenberg matrix H. +*> If a NaN is detected in H, the routine will return with INFO=-6. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the array H. LDH >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[in] WI +*> \verbatim +*> WI is DOUBLE PRECISION array, dimension (N) +*> +*> On entry, the real and imaginary parts of the eigenvalues of +*> H; a complex conjugate pair of eigenvalues must be stored in +*> consecutive elements of WR and WI. +*> On exit, WR may have been altered since close eigenvalues +*> are perturbed slightly in searching for independent +*> eigenvectors. +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is DOUBLE PRECISION array, dimension (LDVL,MM) +*> On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must +*> contain starting vectors for the inverse iteration for the +*> left eigenvectors; the starting vector for each eigenvector +*> must be in the same column(s) in which the eigenvector will +*> be stored. +*> On exit, if SIDE = 'L' or 'B', the left eigenvectors +*> specified by SELECT will be stored consecutively in the +*> columns of VL, in the same order as their eigenvalues. A +*> complex eigenvector corresponding to a complex eigenvalue is +*> stored in two consecutive columns, the first holding the real +*> part and the second the imaginary part. +*> If SIDE = 'R', VL is not referenced. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the array VL. +*> LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +*> \endverbatim +*> +*> \param[in,out] VR +*> \verbatim +*> VR is DOUBLE PRECISION array, dimension (LDVR,MM) +*> On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must +*> contain starting vectors for the inverse iteration for the +*> right eigenvectors; the starting vector for each eigenvector +*> must be in the same column(s) in which the eigenvector will +*> be stored. +*> On exit, if SIDE = 'R' or 'B', the right eigenvectors +*> specified by SELECT will be stored consecutively in the +*> columns of VR, in the same order as their eigenvalues. A +*> complex eigenvector corresponding to a complex eigenvalue is +*> stored in two consecutive columns, the first holding the real +*> part and the second the imaginary part. +*> If SIDE = 'L', VR is not referenced. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. +*> LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +*> \endverbatim +*> +*> \param[in] MM +*> \verbatim +*> MM is INTEGER +*> The number of columns in the arrays VL and/or VR. MM >= M. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The number of columns in the arrays VL and/or VR required to +*> store the eigenvectors; each selected real eigenvector +*> occupies one column and each selected complex eigenvector +*> occupies two columns. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension ((N+2)*N) +*> \endverbatim +*> +*> \param[out] IFAILL +*> \verbatim +*> IFAILL is INTEGER array, dimension (MM) +*> If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left +*> eigenvector in the i-th column of VL (corresponding to the +*> eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the +*> eigenvector converged satisfactorily. If the i-th and (i+1)th +*> columns of VL hold a complex eigenvector, then IFAILL(i) and +*> IFAILL(i+1) are set to the same value. +*> If SIDE = 'R', IFAILL is not referenced. +*> \endverbatim +*> +*> \param[out] IFAILR +*> \verbatim +*> IFAILR is INTEGER array, dimension (MM) +*> If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right +*> eigenvector in the i-th column of VR (corresponding to the +*> eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the +*> eigenvector converged satisfactorily. If the i-th and (i+1)th +*> columns of VR hold a complex eigenvector, then IFAILR(i) and +*> IFAILR(i+1) are set to the same value. +*> If SIDE = 'L', IFAILR is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, i is the number of eigenvectors which +*> failed to converge; see IFAILL and IFAILR for further +*> details. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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|. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, + $ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, + $ IFAILR, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER EIGSRC, INITV, SIDE + INTEGER INFO, LDH, LDVL, LDVR, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + INTEGER IFAILL( * ), IFAILR( * ) + DOUBLE PRECISION H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WI( * ), WORK( * ), WR( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL BOTHV, FROMQR, LEFTV, NOINIT, PAIR, RIGHTV + INTEGER I, IINFO, K, KL, KLN, KR, KSI, KSR, LDWORK + DOUBLE PRECISION BIGNUM, EPS3, HNORM, SMLNUM, ULP, UNFL, WKI, + $ WKR +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + DOUBLE PRECISION DLAMCH, DLANHS + EXTERNAL LSAME, DLAMCH, DLANHS, DISNAN +* .. +* .. External Subroutines .. + EXTERNAL DLAEIN, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters. +* + BOTHV = LSAME( SIDE, 'B' ) + RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV + LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV +* + FROMQR = LSAME( EIGSRC, 'Q' ) +* + NOINIT = LSAME( INITV, 'N' ) +* +* Set M to the number of columns required to store the selected +* eigenvectors, and standardize the array SELECT. +* + M = 0 + PAIR = .FALSE. + DO 10 K = 1, N + IF( PAIR ) THEN + PAIR = .FALSE. + SELECT( K ) = .FALSE. + ELSE + IF( WI( K ).EQ.ZERO ) THEN + IF( SELECT( K ) ) + $ M = M + 1 + ELSE + PAIR = .TRUE. + IF( SELECT( K ) .OR. SELECT( K+1 ) ) THEN + SELECT( K ) = .TRUE. + M = M + 2 + END IF + END IF + END IF + 10 CONTINUE +* + INFO = 0 + IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -1 + ELSE IF( .NOT.FROMQR .AND. .NOT.LSAME( EIGSRC, 'N' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOINIT .AND. .NOT.LSAME( INITV, 'U' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN + INFO = -11 + ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN + INFO = -13 + ELSE IF( MM.LT.M ) THEN + INFO = -14 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DHSEIN', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* +* Set machine-dependent constants. +* + UNFL = DLAMCH( 'Safe minimum' ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( N / ULP ) + BIGNUM = ( ONE-ULP ) / SMLNUM +* + LDWORK = N + 1 +* + KL = 1 + KLN = 0 + IF( FROMQR ) THEN + KR = 0 + ELSE + KR = N + END IF + KSR = 1 +* + DO 120 K = 1, N + IF( SELECT( K ) ) THEN +* +* Compute eigenvector(s) corresponding to W(K). +* + IF( FROMQR ) THEN +* +* If affiliation of eigenvalues is known, check whether +* the matrix splits. +* +* Determine KL and KR such that 1 <= KL <= K <= KR <= N +* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or +* KR = N). +* +* Then inverse iteration can be performed with the +* submatrix H(KL:N,KL:N) for a left eigenvector, and with +* the submatrix H(1:KR,1:KR) for a right eigenvector. +* + DO 20 I = K, KL + 1, -1 + IF( H( I, I-1 ).EQ.ZERO ) + $ GO TO 30 + 20 CONTINUE + 30 CONTINUE + KL = I + IF( K.GT.KR ) THEN + DO 40 I = K, N - 1 + IF( H( I+1, I ).EQ.ZERO ) + $ GO TO 50 + 40 CONTINUE + 50 CONTINUE + KR = I + END IF + END IF +* + IF( KL.NE.KLN ) THEN + KLN = KL +* +* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it +* has not ben computed before. +* + HNORM = DLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, WORK ) + IF( DISNAN( HNORM ) ) THEN + INFO = -6 + RETURN + ELSE IF( HNORM.GT.ZERO ) THEN + EPS3 = HNORM*ULP + ELSE + EPS3 = SMLNUM + END IF + END IF +* +* Perturb eigenvalue if it is close to any previous +* selected eigenvalues affiliated to the submatrix +* H(KL:KR,KL:KR). Close roots are modified by EPS3. +* + WKR = WR( K ) + WKI = WI( K ) + 60 CONTINUE + DO 70 I = K - 1, KL, -1 + IF( SELECT( I ) .AND. ABS( WR( I )-WKR )+ + $ ABS( WI( I )-WKI ).LT.EPS3 ) THEN + WKR = WKR + EPS3 + GO TO 60 + END IF + 70 CONTINUE + WR( K ) = WKR +* + PAIR = WKI.NE.ZERO + IF( PAIR ) THEN + KSI = KSR + 1 + ELSE + KSI = KSR + END IF + IF( LEFTV ) THEN +* +* Compute left eigenvector. +* + CALL DLAEIN( .FALSE., NOINIT, N-KL+1, H( KL, KL ), LDH, + $ WKR, WKI, VL( KL, KSR ), VL( KL, KSI ), + $ WORK, LDWORK, WORK( N*N+N+1 ), EPS3, SMLNUM, + $ BIGNUM, IINFO ) + IF( IINFO.GT.0 ) THEN + IF( PAIR ) THEN + INFO = INFO + 2 + ELSE + INFO = INFO + 1 + END IF + IFAILL( KSR ) = K + IFAILL( KSI ) = K + ELSE + IFAILL( KSR ) = 0 + IFAILL( KSI ) = 0 + END IF + DO 80 I = 1, KL - 1 + VL( I, KSR ) = ZERO + 80 CONTINUE + IF( PAIR ) THEN + DO 90 I = 1, KL - 1 + VL( I, KSI ) = ZERO + 90 CONTINUE + END IF + END IF + IF( RIGHTV ) THEN +* +* Compute right eigenvector. +* + CALL DLAEIN( .TRUE., NOINIT, KR, H, LDH, WKR, WKI, + $ VR( 1, KSR ), VR( 1, KSI ), WORK, LDWORK, + $ WORK( N*N+N+1 ), EPS3, SMLNUM, BIGNUM, + $ IINFO ) + IF( IINFO.GT.0 ) THEN + IF( PAIR ) THEN + INFO = INFO + 2 + ELSE + INFO = INFO + 1 + END IF + IFAILR( KSR ) = K + IFAILR( KSI ) = K + ELSE + IFAILR( KSR ) = 0 + IFAILR( KSI ) = 0 + END IF + DO 100 I = KR + 1, N + VR( I, KSR ) = ZERO + 100 CONTINUE + IF( PAIR ) THEN + DO 110 I = KR + 1, N + VR( I, KSI ) = ZERO + 110 CONTINUE + END IF + END IF +* + IF( PAIR ) THEN + KSR = KSR + 2 + ELSE + KSR = KSR + 1 + END IF + END IF + 120 CONTINUE +* + RETURN +* +* End of DHSEIN +* + END diff --git a/math/lapack/src/main/fortran/dhseqr.f b/math/lapack/src/main/fortran/dhseqr.f new file mode 100644 index 0000000000..4444b955f4 --- /dev/null +++ b/math/lapack/src/main/fortran/dhseqr.f @@ -0,0 +1,516 @@ +*> \brief \b DHSEQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DHSEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, +* LDZ, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N +* CHARACTER COMPZ, JOB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is CHARACTER*1 +*> = 'E': compute eigenvalues only; +*> = 'S': compute eigenvalues and the Schur form T. +*> \endverbatim +*> +*> \param[in] COMPZ +*> \verbatim +*> COMPZ is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H. N .GE. 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is 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 ZGEHRD +*> 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. +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is 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. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the array H. LDH .GE. max(1,N). +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] WI +*> \verbatim +*> WI is 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). +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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.) +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. if COMPZ = 'I' or +*> COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns an estimate of +*> the optimal value for LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK .GE. max(1,N) +*> is sufficient and delivers very good and sometimes +*> optimal performance. However, LWORK as large as 11*N +*> may be required for optimal performance. A workspace +*> query is recommended to determine the optimal workspace +*> size. +*> +*> If LWORK = -1, then DHSEQR does a workspace query. +*> In this case, DHSEQR checks the input parameters and +*> estimates the optimal workspace size for the given +*> values of N, ILO and IHI. The estimate is returned +*> in WORK(1). No error message related to LWORK is +*> issued by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Default values supplied by +*> ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). +*> It is suggested that these defaults be adjusted in order +*> to attain best performance in each particular +*> computational environment. +*> +*> ISPEC=12: The DLAHQR vs DLAQR0 crossover point. +*> Default: 75. (Must be at least 11.) +*> +*> ISPEC=13: Recommended deflation window size. +*> This depends on ILO, IHI and NS. NS is the +*> number of simultaneous shifts returned +*> by ILAENV(ISPEC=15). (See ISPEC=15 below.) +*> The default for (IHI-ILO+1).LE.500 is NS. +*> The default for (IHI-ILO+1).GT.500 is 3*NS/2. +*> +*> ISPEC=14: Nibble crossover point. (See IPARMQ for +*> details.) Default: 14% of deflation window +*> size. +*> +*> ISPEC=15: Number of simultaneous shifts in a multishift +*> QR iteration. +*> +*> If IHI-ILO+1 is ... +*> +*> greater than ...but less ... the +*> or equal to ... than default is +*> +*> 1 30 NS = 2(+) +*> 30 60 NS = 4(+) +*> 60 150 NS = 10(+) +*> 150 590 NS = ** +*> 590 3000 NS = 64 +*> 3000 6000 NS = 128 +*> 6000 infinity NS = 256 +*> +*> (+) By default some or all matrices of this order +*> are passed to the implicit double shift routine +*> DLAHQR and this parameter is ignored. See +*> ISPEC=12 above and comments in IPARMQ for +*> details. +*> +*> (**) The asterisks (**) indicate an ad-hoc +*> function of N increasing from 10 to 64. +*> +*> ISPEC=16: Select structured matrix multiply. +*> If the number of simultaneous shifts (specified +*> by ISPEC=15) is less than 14, then the default +*> for ISPEC=16 is 0. Otherwise the default for +*> ISPEC=16 is 2. +*> \endverbatim +* +*> \par 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. +*> \n +*> 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. +* +* ===================================================================== + SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, + $ LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N + CHARACTER COMPZ, JOB +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. +* +* ==== Matrices of order NTINY or smaller must be processed by +* . DLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) +* +* ==== NL allocates some local workspace to help small matrices +* . through a rare DLAHQR failure. NL .GT. NTINY = 11 is +* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- +* . mended. (The default value of NMIN is 75.) Using NL = 49 +* . allows up to six simultaneous shifts and a 16-by-16 +* . deflation window. ==== + INTEGER 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/math/lapack/src/main/fortran/disnan.f b/math/lapack/src/main/fortran/disnan.f index b9d129a585..da89158fbc 100644 --- a/math/lapack/src/main/fortran/disnan.f +++ b/math/lapack/src/main/fortran/disnan.f @@ -75,6 +75,6 @@ LOGICAL FUNCTION DISNAN( DIN ) EXTERNAL DLAISNAN * .. * .. Executable Statements .. - DISNAN = ISNAN(DIN) + DISNAN = DLAISNAN(DIN,DIN) RETURN END diff --git a/math/lapack/src/main/fortran/dla_gbamv.f b/math/lapack/src/main/fortran/dla_gbamv.f new file mode 100644 index 0000000000..577866cf71 --- /dev/null +++ b/math/lapack/src/main/fortran/dla_gbamv.f @@ -0,0 +1,411 @@ +*> \brief \b DLA_GBAMV performs a matrix-vector operation to calculate error bounds. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_GBAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, +* INCX, BETA, Y, INCY ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA, BETA +* INTEGER INCX, INCY, LDAB, M, N, KL, KU, TRANS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), X( * ), Y( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLA_GBAMV performs one of the matrix-vector operations +*> +*> y := alpha*abs(A)*abs(x) + beta*abs(y), +*> or y := alpha*abs(A)**T*abs(x) + beta*abs(y), +*> +*> where alpha and beta are scalars, x and y are vectors and A is an +*> m by n matrix. +*> +*> This function is primarily used in calculating error bounds. +*> To protect against underflow during evaluation, components in +*> the resulting vector are perturbed away from zero by (N+1) +*> times the underflow threshold. To prevent unnecessarily large +*> errors for block-structure embedded in general matrices, +*> "symbolically" zero components are not perturbed. A zero +*> entry is considered "symbolic" if all multiplications involved +*> in computing that entry have at least one zero multiplicand. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is INTEGER +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) +*> BLAS_TRANS y := alpha*abs(A**T)*abs(x) + beta*abs(y) +*> BLAS_CONJ_TRANS y := alpha*abs(A**T)*abs(x) + beta*abs(y) +*> +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals within the band of A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals within the band of A. KU >= 0. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> On entry, ALPHA specifies the scalar alpha. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array of DIMENSION ( LDAB, n ) +*> Before entry, the leading m by n part of the array AB must +*> contain the matrix of coefficients. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> On entry, LDA specifies the first dimension of AB as declared +*> in the calling (sub) program. LDAB must be at least +*> max( 1, m ). +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension +*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +*> Before entry, the incremented array X must contain the +*> vector x. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension +*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +*> Before entry with BETA non-zero, the incremented array Y +*> must contain the vector y. On exit, Y is overwritten by the +*> updated vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> Unchanged on exit. +*> +*> Level 2 Blas routine. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBcomputational +* +* ===================================================================== + SUBROUTINE DLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, + $ INCX, BETA, Y, INCY ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDAB, M, N, KL, KU, TRANS +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), X( * ), Y( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + DOUBLE PRECISION TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY, LENX, LENY, KD, KE +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLAMCH + DOUBLE PRECISION DLAMCH +* .. +* .. External Functions .. + EXTERNAL ILATRANS + INTEGER ILATRANS +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, SIGN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.( ( TRANS.EQ.ILATRANS( 'N' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'T' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'C' ) ) ) ) THEN + INFO = 1 + ELSE IF( M.LT.0 )THEN + INFO = 2 + ELSE IF( N.LT.0 )THEN + INFO = 3 + ELSE IF( KL.LT.0 .OR. KL.GT.M-1 ) THEN + INFO = 4 + ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN + INFO = 5 + ELSE IF( LDAB.LT.KL+KU+1 )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + ELSE IF( INCY.EQ.0 )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DLA_GBAMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( LENX - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( LENY - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = DLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + KD = KU + 1 + KE = KL + 1 + IY = KY + IF ( INCX.EQ.1 ) THEN + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + DO I = 1, LENY + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + DO J = MAX( I-KL, 1 ), MIN( I+KU, LENX ) + TEMP = ABS( AB( KD+I-J, J ) ) + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + IY = IY + INCY + END DO + ELSE + DO I = 1, LENY + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + DO J = MAX( I-KL, 1 ), MIN( I+KU, LENX ) + TEMP = ABS( AB( KE-I+J, I ) ) + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + IY = IY + INCY + END DO + END IF + ELSE + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + DO I = 1, LENY + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + JX = KX + DO J = MAX( I-KL, 1 ), MIN( I+KU, LENX ) + TEMP = ABS( AB( KD+I-J, J ) ) + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, LENY + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + JX = KX + DO J = MAX( I-KL, 1 ), MIN( I+KU, LENX ) + TEMP = ABS( AB( KE-I+J, I ) ) + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF + + END IF +* + RETURN +* +* End of DLA_GBAMV +* + END diff --git a/math/lapack/src/main/fortran/dla_gbrcond.f b/math/lapack/src/main/fortran/dla_gbrcond.f new file mode 100644 index 0000000000..e9713c9ca9 --- /dev/null +++ b/math/lapack/src/main/fortran/dla_gbrcond.f @@ -0,0 +1,353 @@ +*> \brief \b DLA_GBRCOND estimates the Skeel condition number for a general banded matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_GBRCOND + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, +* AFB, LDAFB, IPIV, CMODE, C, +* INFO, WORK, IWORK ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* INTEGER N, LDAB, LDAFB, INFO, KL, KU, CMODE +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), IPIV( * ) +* DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ), +* $ C( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLA_GBRCOND Estimates the Skeel condition number of op(A) * op2(C) +*> where op2 is determined by CMODE as follows +*> CMODE = 1 op2(C) = C +*> CMODE = 0 op2(C) = I +*> CMODE = -1 op2(C) = inv(C) +*> The Skeel condition number cond(A) = norminf( |inv(A)||A| ) +*> is computed by computing scaling factors R such that +*> diag(R)*A*op2(C) is row equilibrated and computing the standard +*> infinity-norm condition number. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals within the band of A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals within the band of A. KU >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the matrix A in band storage, in rows 1 to KL+KU+1. +*> The j-th column of A is stored in the j-th column of the +*> array AB as follows: +*> AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KL+KU+1. +*> \endverbatim +*> +*> \param[in] AFB +*> \verbatim +*> AFB is DOUBLE PRECISION array, dimension (LDAFB,N) +*> Details of the LU factorization of the band matrix A, as +*> computed by DGBTRF. U is stored as an upper triangular +*> band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, +*> and the multipliers used during the factorization are stored +*> in rows KL+KU+2 to 2*KL+KU+1. +*> \endverbatim +*> +*> \param[in] LDAFB +*> \verbatim +*> LDAFB is INTEGER +*> The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from the factorization A = P*L*U +*> as computed by DGBTRF; row i of the matrix was interchanged +*> with row IPIV(i). +*> \endverbatim +*> +*> \param[in] CMODE +*> \verbatim +*> CMODE is INTEGER +*> Determines op2(C) in the formula op(A) * op2(C) as follows: +*> CMODE = 1 op2(C) = C +*> CMODE = 0 op2(C) = I +*> CMODE = -1 op2(C) = inv(C) +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> The vector C in the formula op(A) * op2(C). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Successful exit. +*> i > 0: The ith argument is invalid. +*> \endverbatim +*> +*> \param[in] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (5*N). +*> Workspace. +*> \endverbatim +*> +*> \param[in] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N). +*> Workspace. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBcomputational +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, + $ AFB, LDAFB, IPIV, CMODE, C, + $ INFO, WORK, IWORK ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER N, LDAB, LDAFB, INFO, KL, KU, CMODE +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), IPIV( * ) + DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ), + $ C( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL NOTRANS + INTEGER KASE, I, J, KD, KE + DOUBLE PRECISION AINVNM, TMP +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DGBTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + DLA_GBRCOND = 0.0D+0 +* + INFO = 0 + NOTRANS = LSAME( TRANS, 'N' ) + IF ( .NOT. NOTRANS .AND. .NOT. LSAME(TRANS, 'T') + $ .AND. .NOT. LSAME(TRANS, 'C') ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KL.LT.0 .OR. KL.GT.N-1 ) THEN + INFO = -3 + ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -6 + ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLA_GBRCOND', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) THEN + DLA_GBRCOND = 1.0D+0 + RETURN + END IF +* +* Compute the equilibration matrix R such that +* inv(R)*A*C has unit 1-norm. +* + KD = KU + 1 + KE = KL + 1 + IF ( NOTRANS ) THEN + DO I = 1, N + TMP = 0.0D+0 + IF ( CMODE .EQ. 1 ) THEN + DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) + TMP = TMP + ABS( AB( KD+I-J, J ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) + TMP = TMP + ABS( AB( KD+I-J, J ) ) + END DO + ELSE + DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) + TMP = TMP + ABS( AB( KD+I-J, J ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + IF ( CMODE .EQ. 1 ) THEN + DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) + TMP = TMP + ABS( AB( KE-I+J, I ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) + TMP = TMP + ABS( AB( KE-I+J, I ) ) + END DO + ELSE + DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) + TMP = TMP + ABS( AB( KE-I+J, I ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 + + KASE = 0 + 10 CONTINUE + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + + IF ( NOTRANS ) THEN + CALL DGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, + $ IPIV, WORK, N, INFO ) + ELSE + CALL DGBTRS( 'Transpose', N, KL, KU, 1, AFB, LDAFB, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by inv(C). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C**T). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + + IF ( NOTRANS ) THEN + CALL DGBTRS( 'Transpose', N, KL, KU, 1, AFB, LDAFB, IPIV, + $ WORK, N, INFO ) + ELSE + CALL DGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, + $ IPIV, WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ DLA_GBRCOND = ( 1.0D+0 / AINVNM ) +* + RETURN +* + END diff --git a/math/lapack/src/main/fortran/dla_gbrfsx_extended.f b/math/lapack/src/main/fortran/dla_gbrfsx_extended.f new file mode 100644 index 0000000000..bab9bbceb6 --- /dev/null +++ b/math/lapack/src/main/fortran/dla_gbrfsx_extended.f @@ -0,0 +1,710 @@ +*> \brief \b DLA_GBRFSX_EXTENDED improves the computed solution to a system of linear equations for general banded matrices by performing extra-precise iterative refinement and provides error bounds and backward error estimates for the solution. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_GBRFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, +* NRHS, AB, LDAB, AFB, LDAFB, IPIV, +* COLEQU, C, B, LDB, Y, LDY, +* BERR_OUT, N_NORMS, ERR_BNDS_NORM, +* ERR_BNDS_COMP, RES, AYB, DY, +* Y_TAIL, RCOND, ITHRESH, RTHRESH, +* DZ_UB, IGNORE_CWISE, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS, +* $ PREC_TYPE, TRANS_TYPE, N_NORMS, ITHRESH +* LOGICAL COLEQU, IGNORE_CWISE +* DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), +* $ Y( LDY, * ), RES(*), DY(*), Y_TAIL(*) +* DOUBLE PRECISION C( * ), AYB(*), RCOND, BERR_OUT(*), +* $ ERR_BNDS_NORM( NRHS, * ), +* $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> +*> DLA_GBRFSX_EXTENDED improves the computed solution to a system of +*> linear equations by performing extra-precise iterative refinement +*> and provides error bounds and backward error estimates for the solution. +*> This subroutine is called by DGBRFSX to perform iterative refinement. +*> In addition to normwise error bound, the code provides maximum +*> componentwise error bound if possible. See comments for ERR_BNDS_NORM +*> and ERR_BNDS_COMP for details of the error bounds. Note that this +*> subroutine is only resonsible for setting the second fields of +*> ERR_BNDS_NORM and ERR_BNDS_COMP. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PREC_TYPE +*> \verbatim +*> PREC_TYPE is INTEGER +*> Specifies the intermediate precision to be used in refinement. +*> The value is defined by ILAPREC(P) where P is a CHARACTER and +*> P = 'S': Single +*> = 'D': Double +*> = 'I': Indigenous +*> = 'X', 'E': Extra +*> \endverbatim +*> +*> \param[in] TRANS_TYPE +*> \verbatim +*> TRANS_TYPE is INTEGER +*> Specifies the transposition operation on A. +*> The value is defined by ILATRANS(T) where T is a CHARACTER and +*> T = 'N': No transpose +*> = 'T': Transpose +*> = 'C': Conjugate transpose +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals within the band of A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals within the band of A. KU >= 0 +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right-hand-sides, i.e., the number of columns of the +*> matrix B. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the N-by-N matrix AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDBA >= max(1,N). +*> \endverbatim +*> +*> \param[in] AFB +*> \verbatim +*> AFB is DOUBLE PRECISION array, dimension (LDAFB,N) +*> The factors L and U from the factorization +*> A = P*L*U as computed by DGBTRF. +*> \endverbatim +*> +*> \param[in] LDAFB +*> \verbatim +*> LDAFB is INTEGER +*> The leading dimension of the array AF. LDAFB >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from the factorization A = P*L*U +*> as computed by DGBTRF; row i of the matrix was interchanged +*> with row IPIV(i). +*> \endverbatim +*> +*> \param[in] COLEQU +*> \verbatim +*> COLEQU is LOGICAL +*> If .TRUE. then column equilibration was done to A before calling +*> this routine. This is needed to compute the solution and error +*> bounds correctly. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> The column scale factors for A. If COLEQU = .FALSE., C +*> is not accessed. If C is input, each element of C should be a power +*> of the radix to ensure a reliable solution and error estimates. +*> Scaling by powers of the radix does not cause rounding errors unless +*> the result underflows or overflows. Rounding errors during scaling +*> lead to refining with a matrix that is not equivalent to the +*> input matrix, producing error estimates that may not be +*> reliable. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right-hand-side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension +*> (LDY,NRHS) +*> On entry, the solution matrix X, as computed by DGBTRS. +*> On exit, the improved solution matrix Y. +*> \endverbatim +*> +*> \param[in] LDY +*> \verbatim +*> LDY is INTEGER +*> The leading dimension of the array Y. LDY >= max(1,N). +*> \endverbatim +*> +*> \param[out] BERR_OUT +*> \verbatim +*> BERR_OUT is DOUBLE PRECISION array, dimension (NRHS) +*> On exit, BERR_OUT(j) contains the componentwise relative backward +*> error for right-hand-side j from the formula +*> max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +*> where abs(Z) is the componentwise absolute value of the matrix +*> or vector Z. This is computed by DLA_LIN_BERR. +*> \endverbatim +*> +*> \param[in] N_NORMS +*> \verbatim +*> N_NORMS is INTEGER +*> Determines which error bounds to return (see ERR_BNDS_NORM +*> and ERR_BNDS_COMP). +*> If N_NORMS >= 1 return normwise error bounds. +*> If N_NORMS >= 2 return componentwise error bounds. +*> \endverbatim +*> +*> \param[in,out] ERR_BNDS_NORM +*> \verbatim +*> ERR_BNDS_NORM is DOUBLE PRECISION array, dimension +*> (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> normwise relative error, which is defined as follows: +*> +*> Normwise relative error in the ith solution vector: +*> max_j (abs(XTRUE(j,i) - X(j,i))) +*> ------------------------------ +*> max_j abs(X(j,i)) +*> +*> The array is indexed by the type of error information as described +*> below. There currently are up to three pieces of information +*> returned. +*> +*> The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_NORM(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * slamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * slamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated normwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * slamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*A, where S scales each row by a power of the +*> radix so all absolute row sums of Z are approximately 1. +*> +*> This subroutine is only responsible for setting the second field +*> above. +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[in,out] ERR_BNDS_COMP +*> \verbatim +*> ERR_BNDS_COMP is DOUBLE PRECISION array, dimension +*> (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> componentwise relative error, which is defined as follows: +*> +*> Componentwise relative error in the ith solution vector: +*> abs(XTRUE(j,i) - X(j,i)) +*> max_j ---------------------- +*> abs(X(j,i)) +*> +*> The array is indexed by the right-hand side i (on which the +*> componentwise relative error depends), and the type of error +*> information as described below. There currently are up to three +*> pieces of information returned for each right-hand side. If +*> componentwise accuracy is not requested (PARAMS(3) = 0.0), then +*> ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +*> the first (:,N_ERR_BNDS) entries are returned. +*> +*> The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_COMP(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * slamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * slamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated componentwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * slamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*(A*diag(x)), where x is the solution for the +*> current right-hand side and S scales each row of +*> A*diag(x) by a power of the radix so all absolute row +*> sums of Z are approximately 1. +*> +*> This subroutine is only responsible for setting the second field +*> above. +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[in] RES +*> \verbatim +*> RES is DOUBLE PRECISION array, dimension (N) +*> Workspace to hold the intermediate residual. +*> \endverbatim +*> +*> \param[in] AYB +*> \verbatim +*> AYB is DOUBLE PRECISION array, dimension (N) +*> Workspace. This can be the same workspace passed for Y_TAIL. +*> \endverbatim +*> +*> \param[in] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension (N) +*> Workspace to hold the intermediate solution. +*> \endverbatim +*> +*> \param[in] Y_TAIL +*> \verbatim +*> Y_TAIL is DOUBLE PRECISION array, dimension (N) +*> Workspace to hold the trailing bits of the intermediate solution. +*> \endverbatim +*> +*> \param[in] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> Reciprocal scaled condition number. This is an estimate of the +*> reciprocal Skeel condition number of the matrix A after +*> equilibration (if done). If this is less than the machine +*> precision (in particular, if it is zero), the matrix is singular +*> to working precision. Note that the error may still be small even +*> if this number is very small and the matrix appears ill- +*> conditioned. +*> \endverbatim +*> +*> \param[in] ITHRESH +*> \verbatim +*> ITHRESH is INTEGER +*> The maximum number of residual computations allowed for +*> refinement. The default is 10. For 'aggressive' set to 100 to +*> permit convergence using approximate factorizations or +*> factorizations other than LU. If the factorization uses a +*> technique other than Gaussian elimination, the guarantees in +*> ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. +*> \endverbatim +*> +*> \param[in] RTHRESH +*> \verbatim +*> RTHRESH is DOUBLE PRECISION +*> Determines when to stop refinement if the error estimate stops +*> decreasing. Refinement will stop when the next solution no longer +*> satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is +*> the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The +*> default value is 0.5. For 'aggressive' set to 0.9 to permit +*> convergence on extremely ill-conditioned matrices. See LAWN 165 +*> for more details. +*> \endverbatim +*> +*> \param[in] DZ_UB +*> \verbatim +*> DZ_UB is DOUBLE PRECISION +*> Determines when to start considering componentwise convergence. +*> Componentwise convergence is only considered after each component +*> of the solution Y is stable, which we definte as the relative +*> change in each component being less than DZ_UB. The default value +*> is 0.25, requiring the first bit to be stable. See LAWN 165 for +*> more details. +*> \endverbatim +*> +*> \param[in] IGNORE_CWISE +*> \verbatim +*> IGNORE_CWISE is LOGICAL +*> If .TRUE. then ignore componentwise convergence. Default value +*> is .FALSE.. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Successful exit. +*> < 0: if INFO = -i, the ith argument to DGBTRS had an illegal +*> value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBcomputational +* +* ===================================================================== + SUBROUTINE DLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, + $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, + $ COLEQU, C, B, LDB, Y, LDY, + $ BERR_OUT, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, RES, AYB, DY, + $ Y_TAIL, RCOND, ITHRESH, RTHRESH, + $ DZ_UB, IGNORE_CWISE, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS, + $ PREC_TYPE, TRANS_TYPE, N_NORMS, ITHRESH + LOGICAL COLEQU, IGNORE_CWISE + DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ Y( LDY, * ), RES(*), DY(*), Y_TAIL(*) + DOUBLE PRECISION C( * ), AYB(*), RCOND, BERR_OUT(*), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + CHARACTER TRANS + INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE + DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL, + $ EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGBTRS, DGBMV, BLAS_DGBMV_X, + $ BLAS_DGBMV2_X, DLA_GBAMV, DLA_WWADDW, DLAMCH, + $ CHLA_TRANSTYPE, DLA_LIN_BERR + DOUBLE PRECISION DLAMCH + CHARACTER CHLA_TRANSTYPE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + IF (INFO.NE.0) RETURN + TRANS = CHLA_TRANSTYPE(TRANS_TYPE) + EPS = DLAMCH( 'Epsilon' ) + HUGEVAL = DLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = DBLE( N ) * EPS + M = KL+KU+1 + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + DXRAT = 0.0D+0 + DXRATMAX = 0.0D+0 + DZRAT = 0.0D+0 + DZRATMAX = 0.0D+0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL DGBMV( TRANS, M, N, KL, KU, -1.0D+0, AB, LDAB, + $ Y( 1, J ), 1, 1.0D+0, RES, 1 ) + ELSE IF ( Y_PREC_STATE .EQ. EXTRA_RESIDUAL ) THEN + CALL BLAS_DGBMV_X( TRANS_TYPE, N, N, KL, KU, + $ -1.0D+0, AB, LDAB, Y( 1, J ), 1, 1.0D+0, RES, 1, + $ PREC_TYPE ) + ELSE + CALL BLAS_DGBMV2_X( TRANS_TYPE, N, N, KL, KU, -1.0D+0, + $ AB, LDAB, Y( 1, J ), Y_TAIL, 1, 1.0D+0, RES, 1, + $ PREC_TYPE ) + END IF + +! XXX: RES is no longer needed. + CALL DCOPY( N, RES, 1, DY, 1 ) + CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV, DY, N, + $ INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0D+0 + NORMY = 0.0D+0 + NORMDX = 0.0D+0 + DZ_Z = 0.0D+0 + YMIN = HUGEVAL + + DO I = 1, N + YK = ABS( Y( I, J ) ) + DYK = ABS( DY( I ) ) + + IF ( YK .NE. 0.0D+0 ) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0D+0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX( NORMDX, DYK ) + END IF + END DO + + IF ( NORMX .NE. 0.0D+0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0D+0 ) THEN + DX_X = 0.0D+0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF ( .NOT.IGNORE_CWISE + $ .AND. YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF ( DXRAT .GT. DXRATMAX ) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0D+0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF +* +* Exit if both normwise and componentwise stopped working, +* but if componentwise is unstable, let it go at least two +* iterations. +* + IF ( X_STATE.NE.WORKING_STATE ) THEN + IF ( IGNORE_CWISE ) GOTO 666 + IF ( Z_STATE.EQ.NOPROG_STATE .OR. Z_STATE.EQ.CONV_STATE ) + $ GOTO 666 + IF ( Z_STATE.EQ.UNSTABLE_STATE .AND. CNT.GT.1 ) GOTO 666 + END IF + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF (Y_PREC_STATE .LT. EXTRA_Y) THEN + CALL DAXPY( N, 1.0D+0, DY, 1, Y(1,J), 1 ) + ELSE + CALL DLA_WWADDW( N, Y(1,J), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF ( N_NORMS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = + $ FINAL_DX_X / (1 - DXRATMAX) + END IF + IF (N_NORMS .GE. 2) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = + $ FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL DGBMV(TRANS, N, N, KL, KU, -1.0D+0, AB, LDAB, Y(1,J), + $ 1, 1.0D+0, RES, 1 ) + + DO I = 1, N + AYB( I ) = ABS( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL DLA_GBAMV( TRANS_TYPE, N, N, KL, KU, 1.0D+0, + $ AB, LDAB, Y(1, J), 1, 1.0D+0, AYB, 1 ) + + CALL DLA_LIN_BERR( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS +* + END DO +* + RETURN + END diff --git a/math/lapack/src/main/fortran/dla_gbrpvgrw.f b/math/lapack/src/main/fortran/dla_gbrpvgrw.f new file mode 100644 index 0000000000..3d566c2025 --- /dev/null +++ b/math/lapack/src/main/fortran/dla_gbrpvgrw.f @@ -0,0 +1,160 @@ +*> \brief \b DLA_GBRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a general banded matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_GBRPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLA_GBRPVGRW( N, KL, KU, NCOLS, AB, +* LDAB, AFB, LDAFB ) +* +* .. Scalar Arguments .. +* INTEGER N, KL, KU, NCOLS, LDAB, LDAFB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLA_GBRPVGRW computes the reciprocal pivot growth factor +*> norm(A)/norm(U). The "max absolute element" norm is used. If this is +*> much less than 1, the stability of the LU factorization of the +*> (equilibrated) matrix A could be poor. This also means that the +*> solution X, estimated condition numbers, and error bounds could be +*> unreliable. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals within the band of A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals within the band of A. KU >= 0. +*> \endverbatim +*> +*> \param[in] NCOLS +*> \verbatim +*> NCOLS is INTEGER +*> The number of columns of the matrix A. NCOLS >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the matrix A in band storage, in rows 1 to KL+KU+1. +*> The j-th column of A is stored in the j-th column of the +*> array AB as follows: +*> AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KL+KU+1. +*> \endverbatim +*> +*> \param[in] AFB +*> \verbatim +*> AFB is DOUBLE PRECISION array, dimension (LDAFB,N) +*> Details of the LU factorization of the band matrix A, as +*> computed by DGBTRF. U is stored as an upper triangular +*> band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, +*> and the multipliers used during the factorization are stored +*> in rows KL+KU+2 to 2*KL+KU+1. +*> \endverbatim +*> +*> \param[in] LDAFB +*> \verbatim +*> LDAFB is INTEGER +*> The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBcomputational +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLA_GBRPVGRW( N, KL, KU, NCOLS, AB, + $ LDAB, AFB, LDAFB ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER N, KL, KU, NCOLS, LDAB, LDAFB +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J, KD + DOUBLE PRECISION AMAX, UMAX, RPVGRW +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + RPVGRW = 1.0D+0 + + KD = KU + 1 + DO J = 1, NCOLS + AMAX = 0.0D+0 + UMAX = 0.0D+0 + DO I = MAX( J-KU, 1 ), MIN( J+KL, N ) + AMAX = MAX( ABS( AB( KD+I-J, J)), AMAX ) + END DO + DO I = MAX( J-KU, 1 ), J + UMAX = MAX( ABS( AFB( KD+I-J, J ) ), UMAX ) + END DO + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + DLA_GBRPVGRW = RPVGRW + END diff --git a/math/lapack/src/main/fortran/dla_geamv.f b/math/lapack/src/main/fortran/dla_geamv.f new file mode 100644 index 0000000000..9a91f6ffc2 --- /dev/null +++ b/math/lapack/src/main/fortran/dla_geamv.f @@ -0,0 +1,396 @@ +*> \brief \b DLA_GEAMV computes a matrix-vector product using a general matrix to calculate error bounds. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_GEAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, +* Y, INCY ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA, BETA +* INTEGER INCX, INCY, LDA, M, N, TRANS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLA_GEAMV performs one of the matrix-vector operations +*> +*> y := alpha*abs(A)*abs(x) + beta*abs(y), +*> or y := alpha*abs(A)**T*abs(x) + beta*abs(y), +*> +*> where alpha and beta are scalars, x and y are vectors and A is an +*> m by n matrix. +*> +*> This function is primarily used in calculating error bounds. +*> To protect against underflow during evaluation, components in +*> the resulting vector are perturbed away from zero by (N+1) +*> times the underflow threshold. To prevent unnecessarily large +*> errors for block-structure embedded in general matrices, +*> "symbolically" zero components are not perturbed. A zero +*> entry is considered "symbolic" if all multiplications involved +*> in computing that entry have at least one zero multiplicand. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is INTEGER +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) +*> BLAS_TRANS y := alpha*abs(A**T)*abs(x) + beta*abs(y) +*> BLAS_CONJ_TRANS y := alpha*abs(A**T)*abs(x) + beta*abs(y) +*> +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> On entry, ALPHA specifies the scalar alpha. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ) +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension +*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +*> Before entry, the incremented array X must contain the +*> vector x. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION +*> Array of DIMENSION at least +*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +*> Before entry with BETA non-zero, the incremented array Y +*> must contain the vector y. On exit, Y is overwritten by the +*> updated vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> Unchanged on exit. +*> +*> Level 2 Blas routine. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE DLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, + $ Y, INCY ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDA, M, N, TRANS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + DOUBLE PRECISION TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY, LENX, LENY +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLAMCH + DOUBLE PRECISION DLAMCH +* .. +* .. External Functions .. + EXTERNAL ILATRANS + INTEGER ILATRANS +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, SIGN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.( ( TRANS.EQ.ILATRANS( 'N' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'T' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'C' )) ) ) THEN + INFO = 1 + ELSE IF( M.LT.0 )THEN + INFO = 2 + ELSE IF( N.LT.0 )THEN + INFO = 3 + ELSE IF( LDA.LT.MAX( 1, M ) )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + ELSE IF( INCY.EQ.0 )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DLA_GEAMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( LENX - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( LENY - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = DLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + IY = KY + IF ( INCX.EQ.1 ) THEN + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + DO I = 1, LENY + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, LENX + TEMP = ABS( A( I, J ) ) + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, LENY + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, LENX + TEMP = ABS( A( J, I ) ) + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF + ELSE + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + DO I = 1, LENY + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + JX = KX + DO J = 1, LENX + TEMP = ABS( A( I, J ) ) + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF (.NOT.SYMB_ZERO) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, LENY + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + JX = KX + DO J = 1, LENX + TEMP = ABS( A( J, I ) ) + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF (.NOT.SYMB_ZERO) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF + + END IF +* + RETURN +* +* End of DLA_GEAMV +* + END diff --git a/math/lapack/src/main/fortran/dla_gercond.f b/math/lapack/src/main/fortran/dla_gercond.f new file mode 100644 index 0000000000..aa93ca5a41 --- /dev/null +++ b/math/lapack/src/main/fortran/dla_gercond.f @@ -0,0 +1,329 @@ +*> \brief \b DLA_GERCOND estimates the Skeel condition number for a general matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_GERCOND + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLA_GERCOND ( TRANS, N, A, LDA, AF, +* LDAF, IPIV, CMODE, C, +* INFO, WORK, IWORK ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* INTEGER N, LDA, LDAF, INFO, CMODE +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), +* $ C( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLA_GERCOND estimates the Skeel condition number of op(A) * op2(C) +*> where op2 is determined by CMODE as follows +*> CMODE = 1 op2(C) = C +*> CMODE = 0 op2(C) = I +*> CMODE = -1 op2(C) = inv(C) +*> The Skeel condition number cond(A) = norminf( |inv(A)||A| ) +*> is computed by computing scaling factors R such that +*> diag(R)*A*op2(C) is row equilibrated and computing the standard +*> infinity-norm condition number. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the N-by-N matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> The factors L and U from the factorization +*> A = P*L*U as computed by DGETRF. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from the factorization A = P*L*U +*> as computed by DGETRF; row i of the matrix was interchanged +*> with row IPIV(i). +*> \endverbatim +*> +*> \param[in] CMODE +*> \verbatim +*> CMODE is INTEGER +*> Determines op2(C) in the formula op(A) * op2(C) as follows: +*> CMODE = 1 op2(C) = C +*> CMODE = 0 op2(C) = I +*> CMODE = -1 op2(C) = inv(C) +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> The vector C in the formula op(A) * op2(C). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Successful exit. +*> i > 0: The ith argument is invalid. +*> \endverbatim +*> +*> \param[in] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N). +*> Workspace. +*> \endverbatim +*> +*> \param[in] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N). +*> Workspace. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLA_GERCOND ( TRANS, N, A, LDA, AF, + $ LDAF, IPIV, CMODE, C, + $ INFO, WORK, IWORK ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER N, LDA, LDAF, INFO, CMODE +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), + $ C( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL NOTRANS + INTEGER KASE, I, J + DOUBLE PRECISION AINVNM, TMP +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DGETRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + DLA_GERCOND = 0.0D+0 +* + INFO = 0 + NOTRANS = LSAME( TRANS, 'N' ) + IF ( .NOT. NOTRANS .AND. .NOT. LSAME(TRANS, 'T') + $ .AND. .NOT. LSAME(TRANS, 'C') ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLA_GERCOND', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) THEN + DLA_GERCOND = 1.0D+0 + RETURN + END IF +* +* Compute the equilibration matrix R such that +* inv(R)*A*C has unit 1-norm. +* + IF (NOTRANS) THEN + DO I = 1, N + TMP = 0.0D+0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, N + TMP = TMP + ABS( A( I, J ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, N + TMP = TMP + ABS( A( I, J ) ) + END DO + ELSE + DO J = 1, N + TMP = TMP + ABS( A( I, J ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, N + TMP = TMP + ABS( A( J, I ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, N + TMP = TMP + ABS( A( J, I ) ) + END DO + ELSE + DO J = 1, N + TMP = TMP + ABS( A( J, I ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 + + KASE = 0 + 10 CONTINUE + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK(I) = WORK(I) * WORK(2*N+I) + END DO + + IF (NOTRANS) THEN + CALL DGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL DGETRS( 'Transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by inv(C). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C**T). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + + IF (NOTRANS) THEN + CALL DGETRS( 'Transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL DGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ DLA_GERCOND = ( 1.0D+0 / AINVNM ) +* + RETURN +* + END diff --git a/math/lapack/src/main/fortran/dla_gerfsx_extended.f b/math/lapack/src/main/fortran/dla_gerfsx_extended.f new file mode 100644 index 0000000000..d6af490255 --- /dev/null +++ b/math/lapack/src/main/fortran/dla_gerfsx_extended.f @@ -0,0 +1,688 @@ +*> \brief \b DLA_GERFSX_EXTENDED improves the computed solution to a system of linear equations for general matrices by performing extra-precise iterative refinement and provides error bounds and backward error estimates for the solution. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_GERFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, +* LDA, AF, LDAF, IPIV, COLEQU, C, B, +* LDB, Y, LDY, BERR_OUT, N_NORMS, +* ERRS_N, ERRS_C, RES, AYB, DY, +* Y_TAIL, RCOND, ITHRESH, RTHRESH, +* DZ_UB, IGNORE_CWISE, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, +* $ TRANS_TYPE, N_NORMS, ITHRESH +* LOGICAL COLEQU, IGNORE_CWISE +* DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), +* $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) +* DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), +* $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> +*> DLA_GERFSX_EXTENDED improves the computed solution to a system of +*> linear equations by performing extra-precise iterative refinement +*> and provides error bounds and backward error estimates for the solution. +*> This subroutine is called by DGERFSX to perform iterative refinement. +*> In addition to normwise error bound, the code provides maximum +*> componentwise error bound if possible. See comments for ERRS_N +*> and ERRS_C for details of the error bounds. Note that this +*> subroutine is only resonsible for setting the second fields of +*> ERRS_N and ERRS_C. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PREC_TYPE +*> \verbatim +*> PREC_TYPE is INTEGER +*> Specifies the intermediate precision to be used in refinement. +*> The value is defined by ILAPREC(P) where P is a CHARACTER and +*> P = 'S': Single +*> = 'D': Double +*> = 'I': Indigenous +*> = 'X', 'E': Extra +*> \endverbatim +*> +*> \param[in] TRANS_TYPE +*> \verbatim +*> TRANS_TYPE is INTEGER +*> Specifies the transposition operation on A. +*> The value is defined by ILATRANS(T) where T is a CHARACTER and +*> T = 'N': No transpose +*> = 'T': Transpose +*> = 'C': Conjugate transpose +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right-hand-sides, i.e., the number of columns of the +*> matrix B. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the N-by-N matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> The factors L and U from the factorization +*> A = P*L*U as computed by DGETRF. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from the factorization A = P*L*U +*> as computed by DGETRF; row i of the matrix was interchanged +*> with row IPIV(i). +*> \endverbatim +*> +*> \param[in] COLEQU +*> \verbatim +*> COLEQU is LOGICAL +*> If .TRUE. then column equilibration was done to A before calling +*> this routine. This is needed to compute the solution and error +*> bounds correctly. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> The column scale factors for A. If COLEQU = .FALSE., C +*> is not accessed. If C is input, each element of C should be a power +*> of the radix to ensure a reliable solution and error estimates. +*> Scaling by powers of the radix does not cause rounding errors unless +*> the result underflows or overflows. Rounding errors during scaling +*> lead to refining with a matrix that is not equivalent to the +*> input matrix, producing error estimates that may not be +*> reliable. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right-hand-side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension +*> (LDY,NRHS) +*> On entry, the solution matrix X, as computed by DGETRS. +*> On exit, the improved solution matrix Y. +*> \endverbatim +*> +*> \param[in] LDY +*> \verbatim +*> LDY is INTEGER +*> The leading dimension of the array Y. LDY >= max(1,N). +*> \endverbatim +*> +*> \param[out] BERR_OUT +*> \verbatim +*> BERR_OUT is DOUBLE PRECISION array, dimension (NRHS) +*> On exit, BERR_OUT(j) contains the componentwise relative backward +*> error for right-hand-side j from the formula +*> max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +*> where abs(Z) is the componentwise absolute value of the matrix +*> or vector Z. This is computed by DLA_LIN_BERR. +*> \endverbatim +*> +*> \param[in] N_NORMS +*> \verbatim +*> N_NORMS is INTEGER +*> Determines which error bounds to return (see ERRS_N +*> and ERRS_C). +*> If N_NORMS >= 1 return normwise error bounds. +*> If N_NORMS >= 2 return componentwise error bounds. +*> \endverbatim +*> +*> \param[in,out] ERRS_N +*> \verbatim +*> ERRS_N is DOUBLE PRECISION array, dimension +*> (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> normwise relative error, which is defined as follows: +*> +*> Normwise relative error in the ith solution vector: +*> max_j (abs(XTRUE(j,i) - X(j,i))) +*> ------------------------------ +*> max_j abs(X(j,i)) +*> +*> The array is indexed by the type of error information as described +*> below. There currently are up to three pieces of information +*> returned. +*> +*> The first index in ERRS_N(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERRS_N(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * slamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * slamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated normwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * slamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*A, where S scales each row by a power of the +*> radix so all absolute row sums of Z are approximately 1. +*> +*> This subroutine is only responsible for setting the second field +*> above. +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[in,out] ERRS_C +*> \verbatim +*> ERRS_C is DOUBLE PRECISION array, dimension +*> (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> componentwise relative error, which is defined as follows: +*> +*> Componentwise relative error in the ith solution vector: +*> abs(XTRUE(j,i) - X(j,i)) +*> max_j ---------------------- +*> abs(X(j,i)) +*> +*> The array is indexed by the right-hand side i (on which the +*> componentwise relative error depends), and the type of error +*> information as described below. There currently are up to three +*> pieces of information returned for each right-hand side. If +*> componentwise accuracy is not requested (PARAMS(3) = 0.0), then +*> ERRS_C is not accessed. If N_ERR_BNDS .LT. 3, then at most +*> the first (:,N_ERR_BNDS) entries are returned. +*> +*> The first index in ERRS_C(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERRS_C(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * slamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * slamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated componentwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * slamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*(A*diag(x)), where x is the solution for the +*> current right-hand side and S scales each row of +*> A*diag(x) by a power of the radix so all absolute row +*> sums of Z are approximately 1. +*> +*> This subroutine is only responsible for setting the second field +*> above. +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[in] RES +*> \verbatim +*> RES is DOUBLE PRECISION array, dimension (N) +*> Workspace to hold the intermediate residual. +*> \endverbatim +*> +*> \param[in] AYB +*> \verbatim +*> AYB is DOUBLE PRECISION array, dimension (N) +*> Workspace. This can be the same workspace passed for Y_TAIL. +*> \endverbatim +*> +*> \param[in] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension (N) +*> Workspace to hold the intermediate solution. +*> \endverbatim +*> +*> \param[in] Y_TAIL +*> \verbatim +*> Y_TAIL is DOUBLE PRECISION array, dimension (N) +*> Workspace to hold the trailing bits of the intermediate solution. +*> \endverbatim +*> +*> \param[in] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> Reciprocal scaled condition number. This is an estimate of the +*> reciprocal Skeel condition number of the matrix A after +*> equilibration (if done). If this is less than the machine +*> precision (in particular, if it is zero), the matrix is singular +*> to working precision. Note that the error may still be small even +*> if this number is very small and the matrix appears ill- +*> conditioned. +*> \endverbatim +*> +*> \param[in] ITHRESH +*> \verbatim +*> ITHRESH is INTEGER +*> The maximum number of residual computations allowed for +*> refinement. The default is 10. For 'aggressive' set to 100 to +*> permit convergence using approximate factorizations or +*> factorizations other than LU. If the factorization uses a +*> technique other than Gaussian elimination, the guarantees in +*> ERRS_N and ERRS_C may no longer be trustworthy. +*> \endverbatim +*> +*> \param[in] RTHRESH +*> \verbatim +*> RTHRESH is DOUBLE PRECISION +*> Determines when to stop refinement if the error estimate stops +*> decreasing. Refinement will stop when the next solution no longer +*> satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is +*> the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The +*> default value is 0.5. For 'aggressive' set to 0.9 to permit +*> convergence on extremely ill-conditioned matrices. See LAWN 165 +*> for more details. +*> \endverbatim +*> +*> \param[in] DZ_UB +*> \verbatim +*> DZ_UB is DOUBLE PRECISION +*> Determines when to start considering componentwise convergence. +*> Componentwise convergence is only considered after each component +*> of the solution Y is stable, which we definte as the relative +*> change in each component being less than DZ_UB. The default value +*> is 0.25, requiring the first bit to be stable. See LAWN 165 for +*> more details. +*> \endverbatim +*> +*> \param[in] IGNORE_CWISE +*> \verbatim +*> IGNORE_CWISE is LOGICAL +*> If .TRUE. then ignore componentwise convergence. Default value +*> is .FALSE.. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Successful exit. +*> < 0: if INFO = -i, the ith argument to DGETRS had an illegal +*> value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE DLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, + $ LDA, AF, LDAF, IPIV, COLEQU, C, B, + $ LDB, Y, LDY, BERR_OUT, N_NORMS, + $ ERRS_N, ERRS_C, RES, AYB, DY, + $ Y_TAIL, RCOND, ITHRESH, RTHRESH, + $ DZ_UB, IGNORE_CWISE, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ TRANS_TYPE, N_NORMS, ITHRESH + LOGICAL COLEQU, IGNORE_CWISE + DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + CHARACTER TRANS + INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE + DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL, + $ EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGETRS, DGEMV, BLAS_DGEMV_X, + $ BLAS_DGEMV2_X, DLA_GEAMV, DLA_WWADDW, DLAMCH, + $ CHLA_TRANSTYPE, DLA_LIN_BERR + DOUBLE PRECISION DLAMCH + CHARACTER CHLA_TRANSTYPE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + IF ( INFO.NE.0 ) RETURN + TRANS = CHLA_TRANSTYPE(TRANS_TYPE) + EPS = DLAMCH( 'Epsilon' ) + HUGEVAL = DLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = DBLE( N ) * EPS +* + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + DXRAT = 0.0D+0 + DXRATMAX = 0.0D+0 + DZRAT = 0.0D+0 + DZRATMAX = 0.0D+0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL DGEMV( TRANS, N, N, -1.0D+0, A, LDA, Y( 1, J ), 1, + $ 1.0D+0, RES, 1 ) + ELSE IF ( Y_PREC_STATE .EQ. EXTRA_RESIDUAL ) THEN + CALL BLAS_DGEMV_X( TRANS_TYPE, N, N, -1.0D+0, A, LDA, + $ Y( 1, J ), 1, 1.0D+0, RES, 1, PREC_TYPE ) + ELSE + CALL BLAS_DGEMV2_X( TRANS_TYPE, N, N, -1.0D+0, A, LDA, + $ Y( 1, J ), Y_TAIL, 1, 1.0D+0, RES, 1, PREC_TYPE ) + END IF + +! XXX: RES is no longer needed. + CALL DCOPY( N, RES, 1, DY, 1 ) + CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, DY, N, INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0D+0 + NORMY = 0.0D+0 + NORMDX = 0.0D+0 + DZ_Z = 0.0D+0 + YMIN = HUGEVAL +* + DO I = 1, N + YK = ABS( Y( I, J ) ) + DYK = ABS( DY( I ) ) + + IF ( YK .NE. 0.0D+0 ) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0D+0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX( NORMDX, DYK ) + END IF + END DO + + IF ( NORMX .NE. 0.0D+0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0D+0 ) THEN + DX_X = 0.0D+0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria +* + IF (.NOT.IGNORE_CWISE + $ .AND. YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF ( DXRAT .GT. DXRATMAX ) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0D+0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF +* +* Exit if both normwise and componentwise stopped working, +* but if componentwise is unstable, let it go at least two +* iterations. +* + IF ( X_STATE.NE.WORKING_STATE ) THEN + IF ( IGNORE_CWISE) GOTO 666 + IF ( Z_STATE.EQ.NOPROG_STATE .OR. Z_STATE.EQ.CONV_STATE ) + $ GOTO 666 + IF ( Z_STATE.EQ.UNSTABLE_STATE .AND. CNT.GT.1 ) GOTO 666 + END IF + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF ( Y_PREC_STATE .LT. EXTRA_Y ) THEN + CALL DAXPY( N, 1.0D+0, DY, 1, Y( 1, J ), 1 ) + ELSE + CALL DLA_WWADDW( N, Y( 1, J ), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds +* + IF (N_NORMS .GE. 1) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF ( N_NORMS .GE. 2 ) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL DGEMV( TRANS, N, N, -1.0D+0, A, LDA, Y(1,J), 1, 1.0D+0, + $ RES, 1 ) + + DO I = 1, N + AYB( I ) = ABS( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL DLA_GEAMV ( TRANS_TYPE, N, N, 1.0D+0, + $ A, LDA, Y(1, J), 1, 1.0D+0, AYB, 1 ) + + CALL DLA_LIN_BERR ( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/math/lapack/src/main/fortran/dla_gerpvgrw.f b/math/lapack/src/main/fortran/dla_gerpvgrw.f new file mode 100644 index 0000000000..88cc7be5f1 --- /dev/null +++ b/math/lapack/src/main/fortran/dla_gerpvgrw.f @@ -0,0 +1,142 @@ +*> \brief \b DLA_GERPVGRW +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_GERPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLA_GERPVGRW( N, NCOLS, A, LDA, AF, +* LDAF ) +* +* .. Scalar Arguments .. +* INTEGER N, NCOLS, LDA, LDAF +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> +*> DLA_GERPVGRW computes the reciprocal pivot growth factor +*> norm(A)/norm(U). The "max absolute element" norm is used. If this is +*> much less than 1, the stability of the LU factorization of the +*> (equilibrated) matrix A could be poor. This also means that the +*> solution X, estimated condition numbers, and error bounds could be +*> unreliable. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NCOLS +*> \verbatim +*> NCOLS is INTEGER +*> The number of columns of the matrix A. NCOLS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the N-by-N matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> The factors L and U from the factorization +*> A = P*L*U as computed by DGETRF. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLA_GERPVGRW( N, NCOLS, A, LDA, AF, + $ LDAF ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER N, NCOLS, LDA, LDAF +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION AMAX, UMAX, RPVGRW +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + RPVGRW = 1.0D+0 + + DO J = 1, NCOLS + AMAX = 0.0D+0 + UMAX = 0.0D+0 + DO I = 1, N + AMAX = MAX( ABS( A( I, J ) ), AMAX ) + END DO + DO I = 1, J + UMAX = MAX( ABS( AF( I, J ) ), UMAX ) + END DO + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + DLA_GERPVGRW = RPVGRW + END diff --git a/math/lapack/src/main/fortran/dla_lin_berr.f b/math/lapack/src/main/fortran/dla_lin_berr.f new file mode 100644 index 0000000000..0fec6989be --- /dev/null +++ b/math/lapack/src/main/fortran/dla_lin_berr.f @@ -0,0 +1,153 @@ +*> \brief \b DLA_LIN_BERR computes a component-wise relative backward error. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_LIN_BERR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) +* +* .. Scalar Arguments .. +* INTEGER N, NZ, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AYB( N, NRHS ), BERR( NRHS ) +* DOUBLE PRECISION RES( N, NRHS ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLA_LIN_BERR computes component-wise relative backward error from +*> the formula +*> max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +*> where abs(Z) is the component-wise absolute value of the matrix +*> or vector Z. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NZ +*> \verbatim +*> NZ is INTEGER +*> We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to +*> guard against spuriously zero residuals. Default value is N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices AYB, RES, and BERR. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] RES +*> \verbatim +*> RES is DOUBLE PRECISION array, dimension (N,NRHS) +*> The residual matrix, i.e., the matrix R in the relative backward +*> error formula above. +*> \endverbatim +*> +*> \param[in] AYB +*> \verbatim +*> AYB is DOUBLE PRECISION array, dimension (N, NRHS) +*> The denominator in the relative backward error formula above, i.e., +*> the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B +*> are from iterative refinement (see dla_gerfsx_extended.f). +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is DOUBLE PRECISION array, dimension (NRHS) +*> The component-wise relative backward error from the formula above. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER N, NZ, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION AYB( N, NRHS ), BERR( NRHS ) + DOUBLE PRECISION RES( N, NRHS ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION TMP + INTEGER I, J +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. External Functions .. + EXTERNAL DLAMCH + DOUBLE PRECISION DLAMCH + DOUBLE PRECISION SAFE1 +* .. +* .. Executable Statements .. +* +* Adding SAFE1 to the numerator guards against spuriously zero +* residuals. A similar safeguard is in the SLA_yyAMV routine used +* to compute AYB. +* + SAFE1 = DLAMCH( 'Safe minimum' ) + SAFE1 = (NZ+1)*SAFE1 + + DO J = 1, NRHS + BERR(J) = 0.0D+0 + DO I = 1, N + IF (AYB(I,J) .NE. 0.0D+0) THEN + TMP = (SAFE1+ABS(RES(I,J)))/AYB(I,J) + BERR(J) = MAX( BERR(J), TMP ) + END IF +* +* If AYB is exactly 0.0 (and if computed by SLA_yyAMV), then we know +* the true residual also must be exactly 0.0. +* + END DO + END DO + END diff --git a/math/lapack/src/main/fortran/dla_porcond.f b/math/lapack/src/main/fortran/dla_porcond.f new file mode 100644 index 0000000000..498e707e33 --- /dev/null +++ b/math/lapack/src/main/fortran/dla_porcond.f @@ -0,0 +1,328 @@ +*> \brief \b DLA_PORCOND estimates the Skeel condition number for a symmetric positive-definite matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_PORCOND + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, +* CMODE, C, INFO, WORK, +* IWORK ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, LDA, LDAF, INFO, CMODE +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), +* $ C( * ) +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C) +*> where op2 is determined by CMODE as follows +*> CMODE = 1 op2(C) = C +*> CMODE = 0 op2(C) = I +*> CMODE = -1 op2(C) = inv(C) +*> The Skeel condition number cond(A) = norminf( |inv(A)||A| ) +*> is computed by computing scaling factors R such that +*> diag(R)*A*op2(C) is row equilibrated and computing the standard +*> infinity-norm condition number. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the N-by-N matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> The triangular factor U or L from the Cholesky factorization +*> A = U**T*U or A = L*L**T, as computed by DPOTRF. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in] CMODE +*> \verbatim +*> CMODE is INTEGER +*> Determines op2(C) in the formula op(A) * op2(C) as follows: +*> CMODE = 1 op2(C) = C +*> CMODE = 0 op2(C) = I +*> CMODE = -1 op2(C) = inv(C) +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> The vector C in the formula op(A) * op2(C). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Successful exit. +*> i > 0: The ith argument is invalid. +*> \endverbatim +*> +*> \param[in] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N). +*> Workspace. +*> \endverbatim +*> +*> \param[in] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N). +*> Workspace. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePOcomputational +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, + $ CMODE, C, INFO, WORK, + $ IWORK ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LDAF, INFO, CMODE + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), + $ C( * ) +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER KASE, I, J + DOUBLE PRECISION AINVNM, TMP + LOGICAL UP +* .. +* .. Array Arguments .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DPOTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + DLA_PORCOND = 0.0D+0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLA_PORCOND', -INFO ) + RETURN + END IF + + IF( N.EQ.0 ) THEN + DLA_PORCOND = 1.0D+0 + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute the equilibration matrix R such that +* inv(R)*A*C has unit 1-norm. +* + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0D+0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( J, I ) * C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( J, I ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) ) + END DO + ELSE + DO J = 1, I + TMP = TMP + ABS( A( J ,I ) / C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( I, J ) * C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( I, J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I ) ) + END DO + ELSE + DO J = 1, I + TMP = TMP + ABS( A( I, J ) / C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ENDIF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 + + KASE = 0 + 10 CONTINUE + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + + IF (UP) THEN + CALL DPOTRS( 'Upper', N, 1, AF, LDAF, WORK, N, INFO ) + ELSE + CALL DPOTRS( 'Lower', N, 1, AF, LDAF, WORK, N, INFO ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C**T). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + + IF ( UP ) THEN + CALL DPOTRS( 'Upper', N, 1, AF, LDAF, WORK, N, INFO ) + ELSE + CALL DPOTRS( 'Lower', N, 1, AF, LDAF, WORK, N, INFO ) + ENDIF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ DLA_PORCOND = ( 1.0D+0 / AINVNM ) +* + RETURN +* + END diff --git a/math/lapack/src/main/fortran/dla_porfsx_extended.f b/math/lapack/src/main/fortran/dla_porfsx_extended.f new file mode 100644 index 0000000000..0e21f0b13b --- /dev/null +++ b/math/lapack/src/main/fortran/dla_porfsx_extended.f @@ -0,0 +1,682 @@ +*> \brief \b DLA_PORFSX_EXTENDED improves the computed solution to a system of linear equations for symmetric or Hermitian positive-definite matrices by performing extra-precise iterative refinement and provides error bounds and backward error estimates for the solution. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_PORFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, +* AF, LDAF, COLEQU, C, B, LDB, Y, +* LDY, BERR_OUT, N_NORMS, +* ERR_BNDS_NORM, ERR_BNDS_COMP, RES, +* AYB, DY, Y_TAIL, RCOND, ITHRESH, +* RTHRESH, DZ_UB, IGNORE_CWISE, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, +* $ N_NORMS, ITHRESH +* CHARACTER UPLO +* LOGICAL COLEQU, IGNORE_CWISE +* DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), +* $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) +* DOUBLE PRECISION C( * ), AYB(*), RCOND, BERR_OUT( * ), +* $ ERR_BNDS_NORM( NRHS, * ), +* $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLA_PORFSX_EXTENDED improves the computed solution to a system of +*> linear equations by performing extra-precise iterative refinement +*> and provides error bounds and backward error estimates for the solution. +*> This subroutine is called by DPORFSX to perform iterative refinement. +*> In addition to normwise error bound, the code provides maximum +*> componentwise error bound if possible. See comments for ERR_BNDS_NORM +*> and ERR_BNDS_COMP for details of the error bounds. Note that this +*> subroutine is only resonsible for setting the second fields of +*> ERR_BNDS_NORM and ERR_BNDS_COMP. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PREC_TYPE +*> \verbatim +*> PREC_TYPE is INTEGER +*> Specifies the intermediate precision to be used in refinement. +*> The value is defined by ILAPREC(P) where P is a CHARACTER and +*> P = 'S': Single +*> = 'D': Double +*> = 'I': Indigenous +*> = 'X', 'E': Extra +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right-hand-sides, i.e., the number of columns of the +*> matrix B. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the N-by-N matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> The triangular factor U or L from the Cholesky factorization +*> A = U**T*U or A = L*L**T, as computed by DPOTRF. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in] COLEQU +*> \verbatim +*> COLEQU is LOGICAL +*> If .TRUE. then column equilibration was done to A before calling +*> this routine. This is needed to compute the solution and error +*> bounds correctly. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> The column scale factors for A. If COLEQU = .FALSE., C +*> is not accessed. If C is input, each element of C should be a power +*> of the radix to ensure a reliable solution and error estimates. +*> Scaling by powers of the radix does not cause rounding errors unless +*> the result underflows or overflows. Rounding errors during scaling +*> lead to refining with a matrix that is not equivalent to the +*> input matrix, producing error estimates that may not be +*> reliable. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right-hand-side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension +*> (LDY,NRHS) +*> On entry, the solution matrix X, as computed by DPOTRS. +*> On exit, the improved solution matrix Y. +*> \endverbatim +*> +*> \param[in] LDY +*> \verbatim +*> LDY is INTEGER +*> The leading dimension of the array Y. LDY >= max(1,N). +*> \endverbatim +*> +*> \param[out] BERR_OUT +*> \verbatim +*> BERR_OUT is DOUBLE PRECISION array, dimension (NRHS) +*> On exit, BERR_OUT(j) contains the componentwise relative backward +*> error for right-hand-side j from the formula +*> max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +*> where abs(Z) is the componentwise absolute value of the matrix +*> or vector Z. This is computed by DLA_LIN_BERR. +*> \endverbatim +*> +*> \param[in] N_NORMS +*> \verbatim +*> N_NORMS is INTEGER +*> Determines which error bounds to return (see ERR_BNDS_NORM +*> and ERR_BNDS_COMP). +*> If N_NORMS >= 1 return normwise error bounds. +*> If N_NORMS >= 2 return componentwise error bounds. +*> \endverbatim +*> +*> \param[in,out] ERR_BNDS_NORM +*> \verbatim +*> ERR_BNDS_NORM is DOUBLE PRECISION array, dimension +*> (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> normwise relative error, which is defined as follows: +*> +*> Normwise relative error in the ith solution vector: +*> max_j (abs(XTRUE(j,i) - X(j,i))) +*> ------------------------------ +*> max_j abs(X(j,i)) +*> +*> The array is indexed by the type of error information as described +*> below. There currently are up to three pieces of information +*> returned. +*> +*> The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_NORM(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * slamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * slamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated normwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * slamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*A, where S scales each row by a power of the +*> radix so all absolute row sums of Z are approximately 1. +*> +*> This subroutine is only responsible for setting the second field +*> above. +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[in,out] ERR_BNDS_COMP +*> \verbatim +*> ERR_BNDS_COMP is DOUBLE PRECISION array, dimension +*> (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> componentwise relative error, which is defined as follows: +*> +*> Componentwise relative error in the ith solution vector: +*> abs(XTRUE(j,i) - X(j,i)) +*> max_j ---------------------- +*> abs(X(j,i)) +*> +*> The array is indexed by the right-hand side i (on which the +*> componentwise relative error depends), and the type of error +*> information as described below. There currently are up to three +*> pieces of information returned for each right-hand side. If +*> componentwise accuracy is not requested (PARAMS(3) = 0.0), then +*> ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +*> the first (:,N_ERR_BNDS) entries are returned. +*> +*> The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_COMP(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * slamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * slamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated componentwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * slamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*(A*diag(x)), where x is the solution for the +*> current right-hand side and S scales each row of +*> A*diag(x) by a power of the radix so all absolute row +*> sums of Z are approximately 1. +*> +*> This subroutine is only responsible for setting the second field +*> above. +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[in] RES +*> \verbatim +*> RES is DOUBLE PRECISION array, dimension (N) +*> Workspace to hold the intermediate residual. +*> \endverbatim +*> +*> \param[in] AYB +*> \verbatim +*> AYB is DOUBLE PRECISION array, dimension (N) +*> Workspace. This can be the same workspace passed for Y_TAIL. +*> \endverbatim +*> +*> \param[in] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension (N) +*> Workspace to hold the intermediate solution. +*> \endverbatim +*> +*> \param[in] Y_TAIL +*> \verbatim +*> Y_TAIL is DOUBLE PRECISION array, dimension (N) +*> Workspace to hold the trailing bits of the intermediate solution. +*> \endverbatim +*> +*> \param[in] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> Reciprocal scaled condition number. This is an estimate of the +*> reciprocal Skeel condition number of the matrix A after +*> equilibration (if done). If this is less than the machine +*> precision (in particular, if it is zero), the matrix is singular +*> to working precision. Note that the error may still be small even +*> if this number is very small and the matrix appears ill- +*> conditioned. +*> \endverbatim +*> +*> \param[in] ITHRESH +*> \verbatim +*> ITHRESH is INTEGER +*> The maximum number of residual computations allowed for +*> refinement. The default is 10. For 'aggressive' set to 100 to +*> permit convergence using approximate factorizations or +*> factorizations other than LU. If the factorization uses a +*> technique other than Gaussian elimination, the guarantees in +*> ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. +*> \endverbatim +*> +*> \param[in] RTHRESH +*> \verbatim +*> RTHRESH is DOUBLE PRECISION +*> Determines when to stop refinement if the error estimate stops +*> decreasing. Refinement will stop when the next solution no longer +*> satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is +*> the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The +*> default value is 0.5. For 'aggressive' set to 0.9 to permit +*> convergence on extremely ill-conditioned matrices. See LAWN 165 +*> for more details. +*> \endverbatim +*> +*> \param[in] DZ_UB +*> \verbatim +*> DZ_UB is DOUBLE PRECISION +*> Determines when to start considering componentwise convergence. +*> Componentwise convergence is only considered after each component +*> of the solution Y is stable, which we definte as the relative +*> change in each component being less than DZ_UB. The default value +*> is 0.25, requiring the first bit to be stable. See LAWN 165 for +*> more details. +*> \endverbatim +*> +*> \param[in] IGNORE_CWISE +*> \verbatim +*> IGNORE_CWISE is LOGICAL +*> If .TRUE. then ignore componentwise convergence. Default value +*> is .FALSE.. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Successful exit. +*> < 0: if INFO = -i, the ith argument to DPOTRS had an illegal +*> value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePOcomputational +* +* ===================================================================== + SUBROUTINE DLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, + $ AF, LDAF, COLEQU, C, B, LDB, Y, + $ LDY, BERR_OUT, N_NORMS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, RES, + $ AYB, DY, Y_TAIL, RCOND, ITHRESH, + $ RTHRESH, DZ_UB, IGNORE_CWISE, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ N_NORMS, ITHRESH + CHARACTER UPLO + LOGICAL COLEQU, IGNORE_CWISE + DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + DOUBLE PRECISION C( * ), AYB(*), RCOND, BERR_OUT( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE + DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, Y_PREC_STATE, BASE_RESIDUAL, + $ EXTRA_RESIDUAL, EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DPOTRS, DSYMV, BLAS_DSYMV_X, + $ BLAS_DSYMV2_X, DLA_SYAMV, DLA_WWADDW, + $ DLA_LIN_BERR + DOUBLE PRECISION DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + IF (INFO.NE.0) RETURN + EPS = DLAMCH( 'Epsilon' ) + HUGEVAL = DLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = DBLE( N ) * EPS + + IF ( LSAME ( UPLO, 'L' ) ) THEN + UPLO2 = ILAUPLO( 'L' ) + ELSE + UPLO2 = ILAUPLO( 'U' ) + ENDIF + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + DXRAT = 0.0D+0 + DXRATMAX = 0.0D+0 + DZRAT = 0.0D+0 + DZRATMAX = 0.0D+0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL DSYMV( UPLO, N, -1.0D+0, A, LDA, Y(1,J), 1, + $ 1.0D+0, RES, 1 ) + ELSE IF ( Y_PREC_STATE .EQ. EXTRA_RESIDUAL ) THEN + CALL BLAS_DSYMV_X( UPLO2, N, -1.0D+0, A, LDA, + $ Y( 1, J ), 1, 1.0D+0, RES, 1, PREC_TYPE ) + ELSE + CALL BLAS_DSYMV2_X(UPLO2, N, -1.0D+0, A, LDA, + $ Y(1, J), Y_TAIL, 1, 1.0D+0, RES, 1, PREC_TYPE) + END IF + +! XXX: RES is no longer needed. + CALL DCOPY( N, RES, 1, DY, 1 ) + CALL DPOTRS( UPLO, N, 1, AF, LDAF, DY, N, INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0D+0 + NORMY = 0.0D+0 + NORMDX = 0.0D+0 + DZ_Z = 0.0D+0 + YMIN = HUGEVAL + + DO I = 1, N + YK = ABS( Y( I, J ) ) + DYK = ABS( DY( I ) ) + + IF ( YK .NE. 0.0D+0 ) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0D+0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX( NORMDX, DYK ) + END IF + END DO + + IF ( NORMX .NE. 0.0D+0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0D+0 ) THEN + DX_X = 0.0D+0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF ( YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF ( DXRAT .GT. DXRATMAX ) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0D+0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF + + IF ( X_STATE.NE.WORKING_STATE.AND. + $ ( IGNORE_CWISE.OR.Z_STATE.NE.WORKING_STATE ) ) + $ GOTO 666 + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF (Y_PREC_STATE .LT. EXTRA_Y) THEN + CALL DAXPY( N, 1.0D+0, DY, 1, Y(1,J), 1 ) + ELSE + CALL DLA_WWADDW( N, Y( 1, J ), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF ( N_NORMS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = + $ FINAL_DX_X / (1 - DXRATMAX) + END IF + IF ( N_NORMS .GE. 2 ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = + $ FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL DSYMV( UPLO, N, -1.0D+0, A, LDA, Y(1,J), 1, 1.0D+0, RES, + $ 1 ) + + DO I = 1, N + AYB( I ) = ABS( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL DLA_SYAMV( UPLO2, N, 1.0D+0, + $ A, LDA, Y(1, J), 1, 1.0D+0, AYB, 1 ) + + CALL DLA_LIN_BERR( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/math/lapack/src/main/fortran/dla_porpvgrw.f b/math/lapack/src/main/fortran/dla_porpvgrw.f new file mode 100644 index 0000000000..4fe1a19223 --- /dev/null +++ b/math/lapack/src/main/fortran/dla_porpvgrw.f @@ -0,0 +1,210 @@ +*> \brief \b DLA_PORPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a symmetric or Hermitian positive-definite matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_PORPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, +* LDAF, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER*1 UPLO +* INTEGER NCOLS, LDA, LDAF +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> +*> DLA_PORPVGRW computes the reciprocal pivot growth factor +*> norm(A)/norm(U). The "max absolute element" norm is used. If this is +*> much less than 1, the stability of the LU factorization of the +*> (equilibrated) matrix A could be poor. This also means that the +*> solution X, estimated condition numbers, and error bounds could be +*> unreliable. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] NCOLS +*> \verbatim +*> NCOLS is INTEGER +*> The number of columns of the matrix A. NCOLS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the N-by-N matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> The triangular factor U or L from the Cholesky factorization +*> A = U**T*U or A = L*L**T, as computed by DPOTRF. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePOcomputational +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, + $ LDAF, WORK ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO + INTEGER NCOLS, LDA, LDAF +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION AMAX, UMAX, RPVGRW + LOGICAL UPPER +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. External Functions .. + EXTERNAL LSAME + LOGICAL LSAME +* .. +* .. Executable Statements .. +* + UPPER = LSAME( 'Upper', UPLO ) +* +* DPOTRF will have factored only the NCOLSxNCOLS leading minor, so +* we restrict the growth search to that minor and use only the first +* 2*NCOLS workspace entries. +* + RPVGRW = 1.0D+0 + DO I = 1, 2*NCOLS + WORK( I ) = 0.0D+0 + END DO +* +* Find the max magnitude entry of each column. +* + IF ( UPPER ) THEN + DO J = 1, NCOLS + DO I = 1, J + WORK( NCOLS+J ) = + $ MAX( ABS( A( I, J ) ), WORK( NCOLS+J ) ) + END DO + END DO + ELSE + DO J = 1, NCOLS + DO I = J, NCOLS + WORK( NCOLS+J ) = + $ MAX( ABS( A( I, J ) ), WORK( NCOLS+J ) ) + END DO + END DO + END IF +* +* Now find the max magnitude entry of each column of the factor in +* AF. No pivoting, so no permutations. +* + IF ( LSAME( 'Upper', UPLO ) ) THEN + DO J = 1, NCOLS + DO I = 1, J + WORK( J ) = MAX( ABS( AF( I, J ) ), WORK( J ) ) + END DO + END DO + ELSE + DO J = 1, NCOLS + DO I = J, NCOLS + WORK( J ) = MAX( ABS( AF( I, J ) ), WORK( J ) ) + END DO + END DO + END IF +* +* Compute the *inverse* of the max element growth factor. Dividing +* by zero would imply the largest entry of the factor's column is +* zero. Than can happen when either the column of A is zero or +* massive pivots made the factor underflow to zero. Neither counts +* as growth in itself, so simply ignore terms with zero +* denominators. +* + IF ( LSAME( 'Upper', UPLO ) ) THEN + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( NCOLS+I ) + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + ELSE + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( NCOLS+I ) + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + END IF + + DLA_PORPVGRW = RPVGRW + END diff --git a/math/lapack/src/main/fortran/dla_syamv.f b/math/lapack/src/main/fortran/dla_syamv.f new file mode 100644 index 0000000000..1f948a2d77 --- /dev/null +++ b/math/lapack/src/main/fortran/dla_syamv.f @@ -0,0 +1,417 @@ +*> \brief \b DLA_SYAMV computes a matrix-vector product using a symmetric indefinite matrix to calculate error bounds. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_SYAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, +* INCY ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA, BETA +* INTEGER INCX, INCY, LDA, N, UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLA_SYAMV performs the matrix-vector operation +*> +*> y := alpha*abs(A)*abs(x) + beta*abs(y), +*> +*> where alpha and beta are scalars, x and y are vectors and A is an +*> n by n symmetric matrix. +*> +*> This function is primarily used in calculating error bounds. +*> To protect against underflow during evaluation, components in +*> the resulting vector are perturbed away from zero by (N+1) +*> times the underflow threshold. To prevent unnecessarily large +*> errors for block-structure embedded in general matrices, +*> "symbolically" zero components are not perturbed. A zero +*> entry is considered "symbolic" if all multiplications involved +*> in computing that entry have at least one zero multiplicand. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is INTEGER +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = BLAS_UPPER Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = BLAS_LOWER Only the lower triangular part of A +*> is to be referenced. +*> +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION . +*> On entry, ALPHA specifies the scalar alpha. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ). +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension +*> ( 1 + ( n - 1 )*abs( INCX ) ) +*> Before entry, the incremented array X must contain the +*> vector x. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION . +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension +*> ( 1 + ( n - 1 )*abs( INCY ) ) +*> Before entry with BETA non-zero, the incremented array Y +*> must contain the vector y. On exit, Y is overwritten by the +*> updated vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> Unchanged on exit. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> -- Modified for the absolute-value product, April 2006 +*> Jason Riedy, UC Berkeley +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, + $ INCY ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDA, N, UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + DOUBLE PRECISION TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLAMCH + DOUBLE PRECISION DLAMCH +* .. +* .. External Functions .. + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, SIGN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( UPLO.NE.ILAUPLO( 'U' ) .AND. + $ UPLO.NE.ILAUPLO( 'L' ) ) THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 5 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + ELSE IF( INCY.EQ.0 )THEN + INFO = 10 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set up the start points in X and Y. +* + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = DLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + IY = KY + IF ( INCX.EQ.1 ) THEN + IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN + DO I = 1, N + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, I + TEMP = ABS( A( J, I ) ) + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP + END DO + DO J = I+1, N + TEMP = ABS( A( I, J ) ) + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, N + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, I + TEMP = ABS( A( I, J ) ) + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP + END DO + DO J = I+1, N + TEMP = ABS( A( J, I ) ) + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF + ELSE + IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN + DO I = 1, N + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + JX = KX + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, I + TEMP = ABS( A( J, I ) ) + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP + JX = JX + INCX + END DO + DO J = I+1, N + TEMP = ABS( A( I, J ) ) + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, N + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + JX = KX + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, I + TEMP = ABS( A( I, J ) ) + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP + JX = JX + INCX + END DO + DO J = I+1, N + TEMP = ABS( A( J, I ) ) + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF + + END IF +* + RETURN +* +* End of DLA_SYAMV +* + END diff --git a/math/lapack/src/main/fortran/dla_syrcond.f b/math/lapack/src/main/fortran/dla_syrcond.f new file mode 100644 index 0000000000..91d5571456 --- /dev/null +++ b/math/lapack/src/main/fortran/dla_syrcond.f @@ -0,0 +1,341 @@ +*> \brief \b DLA_SYRCOND estimates the Skeel condition number for a symmetric indefinite matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_SYRCOND + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, +* IPIV, CMODE, C, INFO, WORK, +* IWORK ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, LDA, LDAF, INFO, CMODE +* .. +* .. Array Arguments +* INTEGER IWORK( * ), IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), C( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLA_SYRCOND estimates the Skeel condition number of op(A) * op2(C) +*> where op2 is determined by CMODE as follows +*> CMODE = 1 op2(C) = C +*> CMODE = 0 op2(C) = I +*> CMODE = -1 op2(C) = inv(C) +*> The Skeel condition number cond(A) = norminf( |inv(A)||A| ) +*> is computed by computing scaling factors R such that +*> diag(R)*A*op2(C) is row equilibrated and computing the standard +*> infinity-norm condition number. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the N-by-N matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by DSYTRF. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF. +*> \endverbatim +*> +*> \param[in] CMODE +*> \verbatim +*> CMODE is INTEGER +*> Determines op2(C) in the formula op(A) * op2(C) as follows: +*> CMODE = 1 op2(C) = C +*> CMODE = 0 op2(C) = I +*> CMODE = -1 op2(C) = inv(C) +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> The vector C in the formula op(A) * op2(C). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Successful exit. +*> i > 0: The ith argument is invalid. +*> \endverbatim +*> +*> \param[in] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N). +*> Workspace. +*> \endverbatim +*> +*> \param[in] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N). +*> Workspace. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, + $ IPIV, CMODE, C, INFO, WORK, + $ IWORK ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LDAF, INFO, CMODE +* .. +* .. Array Arguments + INTEGER IWORK( * ), IPIV( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), C( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + CHARACTER NORMIN + INTEGER KASE, I, J + DOUBLE PRECISION AINVNM, SMLNUM, TMP + LOGICAL UP +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, XERBLA, DSYTRS +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + DLA_SYRCOND = 0.0D+0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLA_SYRCOND', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) THEN + DLA_SYRCOND = 1.0D+0 + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute the equilibration matrix R such that +* inv(R)*A*C has unit 1-norm. +* + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0D+0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( J, I ) * C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( J, I ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) ) + END DO + ELSE + DO J = 1, I + TMP = TMP + ABS( A( J, I ) / C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( I, J ) * C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( I, J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I ) ) + END DO + ELSE + DO J = 1, I + TMP = TMP + ABS( A( I, J) / C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ENDIF +* +* Estimate the norm of inv(op(A)). +* + SMLNUM = DLAMCH( 'Safe minimum' ) + AINVNM = 0.0D+0 + NORMIN = 'N' + + KASE = 0 + 10 CONTINUE + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + + IF ( UP ) THEN + CALL DSYTRS( 'U', N, 1, AF, LDAF, IPIV, WORK, N, INFO ) + ELSE + CALL DSYTRS( 'L', N, 1, AF, LDAF, IPIV, WORK, N, INFO ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C**T). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + + IF ( UP ) THEN + CALL DSYTRS( 'U', N, 1, AF, LDAF, IPIV, WORK, N, INFO ) + ELSE + CALL DSYTRS( 'L', N, 1, AF, LDAF, IPIV, WORK, N, INFO ) + ENDIF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + END IF +* + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ DLA_SYRCOND = ( 1.0D+0 / AINVNM ) +* + RETURN +* + END diff --git a/math/lapack/src/main/fortran/dla_syrfsx_extended.f b/math/lapack/src/main/fortran/dla_syrfsx_extended.f new file mode 100644 index 0000000000..66661f7e2e --- /dev/null +++ b/math/lapack/src/main/fortran/dla_syrfsx_extended.f @@ -0,0 +1,711 @@ +*> \brief \b DLA_SYRFSX_EXTENDED improves the computed solution to a system of linear equations for symmetric indefinite matrices by performing extra-precise iterative refinement and provides error bounds and backward error estimates for the solution. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_SYRFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, +* AF, LDAF, IPIV, COLEQU, C, B, LDB, +* Y, LDY, BERR_OUT, N_NORMS, +* ERR_BNDS_NORM, ERR_BNDS_COMP, RES, +* AYB, DY, Y_TAIL, RCOND, ITHRESH, +* RTHRESH, DZ_UB, IGNORE_CWISE, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, +* $ N_NORMS, ITHRESH +* CHARACTER UPLO +* LOGICAL COLEQU, IGNORE_CWISE +* DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), +* $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) +* DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), +* $ ERR_BNDS_NORM( NRHS, * ), +* $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> +*> DLA_SYRFSX_EXTENDED improves the computed solution to a system of +*> linear equations by performing extra-precise iterative refinement +*> and provides error bounds and backward error estimates for the solution. +*> This subroutine is called by DSYRFSX to perform iterative refinement. +*> In addition to normwise error bound, the code provides maximum +*> componentwise error bound if possible. See comments for ERR_BNDS_NORM +*> and ERR_BNDS_COMP for details of the error bounds. Note that this +*> subroutine is only resonsible for setting the second fields of +*> ERR_BNDS_NORM and ERR_BNDS_COMP. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PREC_TYPE +*> \verbatim +*> PREC_TYPE is INTEGER +*> Specifies the intermediate precision to be used in refinement. +*> The value is defined by ILAPREC(P) where P is a CHARACTER and +*> P = 'S': Single +*> = 'D': Double +*> = 'I': Indigenous +*> = 'X', 'E': Extra +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right-hand-sides, i.e., the number of columns of the +*> matrix B. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the N-by-N matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by DSYTRF. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF. +*> \endverbatim +*> +*> \param[in] COLEQU +*> \verbatim +*> COLEQU is LOGICAL +*> If .TRUE. then column equilibration was done to A before calling +*> this routine. This is needed to compute the solution and error +*> bounds correctly. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> The column scale factors for A. If COLEQU = .FALSE., C +*> is not accessed. If C is input, each element of C should be a power +*> of the radix to ensure a reliable solution and error estimates. +*> Scaling by powers of the radix does not cause rounding errors unless +*> the result underflows or overflows. Rounding errors during scaling +*> lead to refining with a matrix that is not equivalent to the +*> input matrix, producing error estimates that may not be +*> reliable. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right-hand-side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension +*> (LDY,NRHS) +*> On entry, the solution matrix X, as computed by DSYTRS. +*> On exit, the improved solution matrix Y. +*> \endverbatim +*> +*> \param[in] LDY +*> \verbatim +*> LDY is INTEGER +*> The leading dimension of the array Y. LDY >= max(1,N). +*> \endverbatim +*> +*> \param[out] BERR_OUT +*> \verbatim +*> BERR_OUT is DOUBLE PRECISION array, dimension (NRHS) +*> On exit, BERR_OUT(j) contains the componentwise relative backward +*> error for right-hand-side j from the formula +*> max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +*> where abs(Z) is the componentwise absolute value of the matrix +*> or vector Z. This is computed by DLA_LIN_BERR. +*> \endverbatim +*> +*> \param[in] N_NORMS +*> \verbatim +*> N_NORMS is INTEGER +*> Determines which error bounds to return (see ERR_BNDS_NORM +*> and ERR_BNDS_COMP). +*> If N_NORMS >= 1 return normwise error bounds. +*> If N_NORMS >= 2 return componentwise error bounds. +*> \endverbatim +*> +*> \param[in,out] ERR_BNDS_NORM +*> \verbatim +*> ERR_BNDS_NORM is DOUBLE PRECISION array, dimension +*> (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> normwise relative error, which is defined as follows: +*> +*> Normwise relative error in the ith solution vector: +*> max_j (abs(XTRUE(j,i) - X(j,i))) +*> ------------------------------ +*> max_j abs(X(j,i)) +*> +*> The array is indexed by the type of error information as described +*> below. There currently are up to three pieces of information +*> returned. +*> +*> The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_NORM(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * slamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * slamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated normwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * slamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*A, where S scales each row by a power of the +*> radix so all absolute row sums of Z are approximately 1. +*> +*> This subroutine is only responsible for setting the second field +*> above. +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[in,out] ERR_BNDS_COMP +*> \verbatim +*> ERR_BNDS_COMP is DOUBLE PRECISION array, dimension +*> (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> componentwise relative error, which is defined as follows: +*> +*> Componentwise relative error in the ith solution vector: +*> abs(XTRUE(j,i) - X(j,i)) +*> max_j ---------------------- +*> abs(X(j,i)) +*> +*> The array is indexed by the right-hand side i (on which the +*> componentwise relative error depends), and the type of error +*> information as described below. There currently are up to three +*> pieces of information returned for each right-hand side. If +*> componentwise accuracy is not requested (PARAMS(3) = 0.0), then +*> ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +*> the first (:,N_ERR_BNDS) entries are returned. +*> +*> The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_COMP(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * slamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * slamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated componentwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * slamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*(A*diag(x)), where x is the solution for the +*> current right-hand side and S scales each row of +*> A*diag(x) by a power of the radix so all absolute row +*> sums of Z are approximately 1. +*> +*> This subroutine is only responsible for setting the second field +*> above. +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[in] RES +*> \verbatim +*> RES is DOUBLE PRECISION array, dimension (N) +*> Workspace to hold the intermediate residual. +*> \endverbatim +*> +*> \param[in] AYB +*> \verbatim +*> AYB is DOUBLE PRECISION array, dimension (N) +*> Workspace. This can be the same workspace passed for Y_TAIL. +*> \endverbatim +*> +*> \param[in] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension (N) +*> Workspace to hold the intermediate solution. +*> \endverbatim +*> +*> \param[in] Y_TAIL +*> \verbatim +*> Y_TAIL is DOUBLE PRECISION array, dimension (N) +*> Workspace to hold the trailing bits of the intermediate solution. +*> \endverbatim +*> +*> \param[in] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> Reciprocal scaled condition number. This is an estimate of the +*> reciprocal Skeel condition number of the matrix A after +*> equilibration (if done). If this is less than the machine +*> precision (in particular, if it is zero), the matrix is singular +*> to working precision. Note that the error may still be small even +*> if this number is very small and the matrix appears ill- +*> conditioned. +*> \endverbatim +*> +*> \param[in] ITHRESH +*> \verbatim +*> ITHRESH is INTEGER +*> The maximum number of residual computations allowed for +*> refinement. The default is 10. For 'aggressive' set to 100 to +*> permit convergence using approximate factorizations or +*> factorizations other than LU. If the factorization uses a +*> technique other than Gaussian elimination, the guarantees in +*> ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. +*> \endverbatim +*> +*> \param[in] RTHRESH +*> \verbatim +*> RTHRESH is DOUBLE PRECISION +*> Determines when to stop refinement if the error estimate stops +*> decreasing. Refinement will stop when the next solution no longer +*> satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is +*> the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The +*> default value is 0.5. For 'aggressive' set to 0.9 to permit +*> convergence on extremely ill-conditioned matrices. See LAWN 165 +*> for more details. +*> \endverbatim +*> +*> \param[in] DZ_UB +*> \verbatim +*> DZ_UB is DOUBLE PRECISION +*> Determines when to start considering componentwise convergence. +*> Componentwise convergence is only considered after each component +*> of the solution Y is stable, which we definte as the relative +*> change in each component being less than DZ_UB. The default value +*> is 0.25, requiring the first bit to be stable. See LAWN 165 for +*> more details. +*> \endverbatim +*> +*> \param[in] IGNORE_CWISE +*> \verbatim +*> IGNORE_CWISE is LOGICAL +*> If .TRUE. then ignore componentwise convergence. Default value +*> is .FALSE.. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Successful exit. +*> < 0: if INFO = -i, the ith argument to DLA_SYRFSX_EXTENDED had an illegal +*> value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, + $ AF, LDAF, IPIV, COLEQU, C, B, LDB, + $ Y, LDY, BERR_OUT, N_NORMS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, RES, + $ AYB, DY, Y_TAIL, RCOND, ITHRESH, + $ RTHRESH, DZ_UB, IGNORE_CWISE, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ N_NORMS, ITHRESH + CHARACTER UPLO + LOGICAL COLEQU, IGNORE_CWISE + DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE + DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC, UPPER +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, Y_PREC_STATE, BASE_RESIDUAL, + $ EXTRA_RESIDUAL, EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSYTRS, DSYMV, BLAS_DSYMV_X, + $ BLAS_DSYMV2_X, DLA_SYAMV, DLA_WWADDW, + $ DLA_LIN_BERR + DOUBLE PRECISION DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDY.LT.MAX( 1, N ) ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLA_SYRFSX_EXTENDED', -INFO ) + RETURN + END IF + EPS = DLAMCH( 'Epsilon' ) + HUGEVAL = DLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = DBLE( N )*EPS + + IF ( LSAME ( UPLO, 'L' ) ) THEN + UPLO2 = ILAUPLO( 'L' ) + ELSE + UPLO2 = ILAUPLO( 'U' ) + ENDIF + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + DXRAT = 0.0D+0 + DXRATMAX = 0.0D+0 + DZRAT = 0.0D+0 + DZRATMAX = 0.0D+0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) + IF (Y_PREC_STATE .EQ. BASE_RESIDUAL) THEN + CALL DSYMV( UPLO, N, -1.0D+0, A, LDA, Y(1,J), 1, + $ 1.0D+0, RES, 1 ) + ELSE IF (Y_PREC_STATE .EQ. EXTRA_RESIDUAL) THEN + CALL BLAS_DSYMV_X( UPLO2, N, -1.0D+0, A, LDA, + $ Y( 1, J ), 1, 1.0D+0, RES, 1, PREC_TYPE ) + ELSE + CALL BLAS_DSYMV2_X(UPLO2, N, -1.0D+0, A, LDA, + $ Y(1, J), Y_TAIL, 1, 1.0D+0, RES, 1, PREC_TYPE) + END IF + +! XXX: RES is no longer needed. + CALL DCOPY( N, RES, 1, DY, 1 ) + CALL DSYTRS( UPLO, N, 1, AF, LDAF, IPIV, DY, N, INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0D+0 + NORMY = 0.0D+0 + NORMDX = 0.0D+0 + DZ_Z = 0.0D+0 + YMIN = HUGEVAL + + DO I = 1, N + YK = ABS( Y( I, J ) ) + DYK = ABS( DY( I ) ) + + IF ( YK .NE. 0.0D+0 ) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0D+0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX(NORMDX, DYK) + END IF + END DO + + IF ( NORMX .NE. 0.0D+0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0D+0 ) THEN + DX_X = 0.0D+0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF ( YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF ( DXRAT .GT. DXRATMAX ) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0D+0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF + + IF ( X_STATE.NE.WORKING_STATE.AND. + $ ( IGNORE_CWISE.OR.Z_STATE.NE.WORKING_STATE ) ) + $ GOTO 666 + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF (Y_PREC_STATE .LT. EXTRA_Y) THEN + CALL DAXPY( N, 1.0D+0, DY, 1, Y(1,J), 1 ) + ELSE + CALL DLA_WWADDW( N, Y(1,J), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF ( N_NORMS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = + $ FINAL_DX_X / (1 - DXRATMAX) + END IF + IF ( N_NORMS .GE. 2 ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = + $ FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). + CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL DSYMV( UPLO, N, -1.0D+0, A, LDA, Y(1,J), 1, 1.0D+0, RES, + $ 1 ) + + DO I = 1, N + AYB( I ) = ABS( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL DLA_SYAMV( UPLO2, N, 1.0D+0, + $ A, LDA, Y(1, J), 1, 1.0D+0, AYB, 1 ) + + CALL DLA_LIN_BERR( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/math/lapack/src/main/fortran/dla_syrpvgrw.f b/math/lapack/src/main/fortran/dla_syrpvgrw.f new file mode 100644 index 0000000000..c2e5cb018d --- /dev/null +++ b/math/lapack/src/main/fortran/dla_syrpvgrw.f @@ -0,0 +1,320 @@ +*> \brief \b DLA_SYRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a symmetric indefinite matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_SYRPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, +* LDAF, IPIV, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER*1 UPLO +* INTEGER N, INFO, LDA, LDAF +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> +*> DLA_SYRPVGRW computes the reciprocal pivot growth factor +*> norm(A)/norm(U). The "max absolute element" norm is used. If this is +*> much less than 1, the stability of the LU factorization of the +*> (equilibrated) matrix A could be poor. This also means that the +*> solution X, estimated condition numbers, and error bounds could be +*> unreliable. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] INFO +*> \verbatim +*> INFO is INTEGER +*> The value of INFO returned from DSYTRF, .i.e., the pivot in +*> column INFO is exactly 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the N-by-N matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by DSYTRF. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF. +*> \endverbatim +*> +*> \param[in] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, + $ LDAF, IPIV, WORK ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO + INTEGER N, INFO, LDA, LDAF +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER NCOLS, I, J, K, KP + DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP + LOGICAL UPPER +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. External Functions .. + EXTERNAL LSAME + LOGICAL LSAME +* .. +* .. Executable Statements .. +* + UPPER = LSAME( 'Upper', UPLO ) + IF ( INFO.EQ.0 ) THEN + IF ( UPPER ) THEN + NCOLS = 1 + ELSE + NCOLS = N + END IF + ELSE + NCOLS = INFO + END IF + + RPVGRW = 1.0D+0 + DO I = 1, 2*N + WORK( I ) = 0.0D+0 + END DO +* +* Find the max magnitude entry of each column of A. Compute the max +* for all N columns so we can apply the pivot permutation while +* looping below. Assume a full factorization is the common case. +* + IF ( UPPER ) THEN + DO J = 1, N + DO I = 1, J + WORK( N+I ) = MAX( ABS( A( I, J ) ), WORK( N+I ) ) + WORK( N+J ) = MAX( ABS( A( I, J ) ), WORK( N+J ) ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + WORK( N+I ) = MAX( ABS( A( I, J ) ), WORK( N+I ) ) + WORK( N+J ) = MAX( ABS( A( I, J ) ), WORK( N+J ) ) + END DO + END DO + END IF +* +* Now find the max magnitude entry of each column of U or L. Also +* permute the magnitudes of A above so they're in the same order as +* the factor. +* +* The iteration orders and permutations were copied from dsytrs. +* Calls to SSWAP would be severe overkill. +* + IF ( UPPER ) THEN + K = N + DO WHILE ( K .LT. NCOLS .AND. K.GT.0 ) + IF ( IPIV( K ).GT.0 ) THEN +! 1x1 pivot + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + DO I = 1, K + WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) + END DO + K = K - 1 + ELSE +! 2x2 pivot + KP = -IPIV( K ) + TMP = WORK( N+K-1 ) + WORK( N+K-1 ) = WORK( N+KP ) + WORK( N+KP ) = TMP + DO I = 1, K-1 + WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) + WORK( K-1 ) = MAX( ABS( AF( I, K-1 ) ), WORK( K-1 ) ) + END DO + WORK( K ) = MAX( ABS( AF( K, K ) ), WORK( K ) ) + K = K - 2 + END IF + END DO + K = NCOLS + DO WHILE ( K .LE. N ) + IF ( IPIV( K ).GT.0 ) THEN + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + K = K + 1 + ELSE + KP = -IPIV( K ) + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + K = K + 2 + END IF + END DO + ELSE + K = 1 + DO WHILE ( K .LE. NCOLS ) + IF ( IPIV( K ).GT.0 ) THEN +! 1x1 pivot + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + DO I = K, N + WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) + END DO + K = K + 1 + ELSE +! 2x2 pivot + KP = -IPIV( K ) + TMP = WORK( N+K+1 ) + WORK( N+K+1 ) = WORK( N+KP ) + WORK( N+KP ) = TMP + DO I = K+1, N + WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) + WORK( K+1 ) = MAX( ABS( AF(I, K+1 ) ), WORK( K+1 ) ) + END DO + WORK( K ) = MAX( ABS( AF( K, K ) ), WORK( K ) ) + K = K + 2 + END IF + END DO + K = NCOLS + DO WHILE ( K .GE. 1 ) + IF ( IPIV( K ).GT.0 ) THEN + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + K = K - 1 + ELSE + KP = -IPIV( K ) + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + K = K - 2 + ENDIF + END DO + END IF +* +* Compute the *inverse* of the max element growth factor. Dividing +* by zero would imply the largest entry of the factor's column is +* zero. Than can happen when either the column of A is zero or +* massive pivots made the factor underflow to zero. Neither counts +* as growth in itself, so simply ignore terms with zero +* denominators. +* + IF ( UPPER ) THEN + DO I = NCOLS, N + UMAX = WORK( I ) + AMAX = WORK( N+I ) + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + ELSE + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( N+I ) + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + END IF + + DLA_SYRPVGRW = RPVGRW + END diff --git a/math/lapack/src/main/fortran/dla_wwaddw.f b/math/lapack/src/main/fortran/dla_wwaddw.f new file mode 100644 index 0000000000..99a86c5535 --- /dev/null +++ b/math/lapack/src/main/fortran/dla_wwaddw.f @@ -0,0 +1,111 @@ +*> \brief \b DLA_WWADDW adds a vector into a doubled-single vector. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLA_WWADDW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLA_WWADDW( N, X, Y, W ) +* +* .. Scalar Arguments .. +* INTEGER N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION X( * ), Y( * ), W( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLA_WWADDW adds a vector W into a doubled-single vector (X, Y). +*> +*> This works for all extant IBM's hex and binary floating point +*> arithmetics, but not for decimal. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The length of vectors X, Y, and W. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (N) +*> The first part of the doubled-single accumulation vector. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension (N) +*> The second part of the doubled-single accumulation vector. +*> \endverbatim +*> +*> \param[in] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The vector to be added. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DLA_WWADDW( N, X, Y, W ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER N +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ), Y( * ), W( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION S + INTEGER I +* .. +* .. Executable Statements .. +* + DO 10 I = 1, N + S = X(I) + W(I) + S = (S + S) - S + Y(I) = ((X(I) - S) + W(I)) + Y(I) + X(I) = S + 10 CONTINUE + RETURN + END diff --git a/math/lapack/src/main/fortran/dlabad.f b/math/lapack/src/main/fortran/dlabad.f new file mode 100644 index 0000000000..01b8158f66 --- /dev/null +++ b/math/lapack/src/main/fortran/dlabad.f @@ -0,0 +1,105 @@ +*> \brief \b DLABAD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLABAD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLABAD( SMALL, LARGE ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION LARGE, SMALL +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in,out] SMALL +*> \verbatim +*> SMALL is 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. +*> \endverbatim +*> +*> \param[in,out] LARGE +*> \verbatim +*> LARGE is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLABAD( SMALL, LARGE ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION LARGE, SMALL +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlabrd.f b/math/lapack/src/main/fortran/dlabrd.f new file mode 100644 index 0000000000..36c2e85bc1 --- /dev/null +++ b/math/lapack/src/main/fortran/dlabrd.f @@ -0,0 +1,381 @@ +*> \brief \b DLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLABRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, +* LDY ) +* +* .. Scalar Arguments .. +* INTEGER LDA, LDX, LDY, M, N, NB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), +* $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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**T * 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 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows in the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns in the matrix A. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The number of leading rows and columns of A to be reduced. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the m by n general matrix to be reduced. +*> On exit, 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (NB) +*> The diagonal elements of the first NB rows and columns of +*> the reduced matrix. D(i) = A(i,i). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (NB) +*> The off-diagonal elements of the first NB rows and columns of +*> the reduced matrix. +*> \endverbatim +*> +*> \param[out] TAUQ +*> \verbatim +*> TAUQ is DOUBLE PRECISION array dimension (NB) +*> The scalar factors of the elementary reflectors which +*> represent the orthogonal matrix Q. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP +*> \verbatim +*> TAUP is DOUBLE PRECISION array, dimension (NB) +*> The scalar factors of the elementary reflectors which +*> represent the orthogonal matrix P. See Further Details. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NB) +*> The m-by-nb matrix X required to update the unreduced part +*> of A. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,M). +*> \endverbatim +*> +*> \param[out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension (LDY,NB) +*> The n-by-nb matrix Y required to update the unreduced part +*> of A. +*> \endverbatim +*> +*> \param[in] LDY +*> \verbatim +*> LDY is INTEGER +*> The leading dimension of the array Y. LDY >= max(1,N). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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**T and G(i) = I - taup * u * u**T +*> +*> 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**T 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**T - X*U**T. +*> +*> 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). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, + $ LDY ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER LDA, LDX, LDY, M, N, NB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), + $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlacn2.f b/math/lapack/src/main/fortran/dlacn2.f new file mode 100644 index 0000000000..952854043a --- /dev/null +++ b/math/lapack/src/main/fortran/dlacn2.f @@ -0,0 +1,294 @@ +*> \brief \b DLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLACN2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) +* +* .. Scalar Arguments .. +* INTEGER KASE, N +* DOUBLE PRECISION EST +* .. +* .. Array Arguments .. +* INTEGER ISGN( * ), ISAVE( 3 ) +* DOUBLE PRECISION V( * ), X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLACN2 estimates the 1-norm of a square, real matrix A. +*> Reverse communication is used for evaluating matrix-vector products. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 1. +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (N) +*> On the final return, V = A*W, where EST = norm(V)/norm(W) +*> (W is not returned). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (N) +*> On an intermediate return, X should be overwritten by +*> A * X, if KASE=1, +*> A**T * X, if KASE=2, +*> and DLACN2 must be re-called with all the other parameters +*> unchanged. +*> \endverbatim +*> +*> \param[out] ISGN +*> \verbatim +*> ISGN is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[in,out] EST +*> \verbatim +*> EST is 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). +*> \endverbatim +*> +*> \param[in,out] KASE +*> \verbatim +*> KASE is 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**T * X. +*> On the final return from DLACN2, KASE will again be 0. +*> \endverbatim +*> +*> \param[in,out] ISAVE +*> \verbatim +*> ISAVE is INTEGER array, dimension (3) +*> ISAVE is used to save variables between calls to DLACN2 +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Originally named SONEST, dated March 16, 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) +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> Nick Higham, University of Manchester +* +*> \par References: +* ================ +*> +*> 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. +*> +* ===================================================================== + SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER KASE, N + DOUBLE PRECISION EST +* .. +* .. Array Arguments .. + INTEGER ISGN( * ), ISAVE( 3 ) + DOUBLE PRECISION V( * ), X( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlacon.f b/math/lapack/src/main/fortran/dlacon.f new file mode 100644 index 0000000000..0077f7c8a3 --- /dev/null +++ b/math/lapack/src/main/fortran/dlacon.f @@ -0,0 +1,275 @@ +*> \brief \b DLACON estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLACON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) +* +* .. Scalar Arguments .. +* INTEGER KASE, N +* DOUBLE PRECISION EST +* .. +* .. Array Arguments .. +* INTEGER ISGN( * ) +* DOUBLE PRECISION V( * ), X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLACON estimates the 1-norm of a square, real matrix A. +*> Reverse communication is used for evaluating matrix-vector products. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 1. +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (N) +*> On the final return, V = A*W, where EST = norm(V)/norm(W) +*> (W is not returned). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (N) +*> On an intermediate return, X should be overwritten by +*> A * X, if KASE=1, +*> A**T * X, if KASE=2, +*> and DLACON must be re-called with all the other parameters +*> unchanged. +*> \endverbatim +*> +*> \param[out] ISGN +*> \verbatim +*> ISGN is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[in,out] EST +*> \verbatim +*> EST is 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). +*> \endverbatim +*> +*> \param[in,out] KASE +*> \verbatim +*> KASE is 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**T * X. +*> On the final return from DLACON, KASE will again be 0. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Nick Higham, University of Manchester. \n +*> Originally named SONEST, dated March 16, 1988. +* +*> \par References: +* ================ +*> +*> 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. +*> +* ===================================================================== + SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER KASE, N + DOUBLE PRECISION EST +* .. +* .. Array Arguments .. + INTEGER ISGN( * ) + DOUBLE PRECISION V( * ), X( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlacpy.f b/math/lapack/src/main/fortran/dlacpy.f new file mode 100644 index 0000000000..d1c396724a --- /dev/null +++ b/math/lapack/src/main/fortran/dlacpy.f @@ -0,0 +1,156 @@ +*> \brief \b DLACPY copies all or part of one two-dimensional array to another. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLACPY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDB, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLACPY copies all or part of a two-dimensional matrix A to another +*> matrix B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is 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 +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On exit, B = A in the locations specified by UPLO. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dladiv.f b/math/lapack/src/main/fortran/dladiv.f new file mode 100644 index 0000000000..dd8110adf2 --- /dev/null +++ b/math/lapack/src/main/fortran/dladiv.f @@ -0,0 +1,256 @@ +*> \brief \b DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLADIV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLADIV( A, B, C, D, P, Q ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION A, B, C, D, P, Q +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLADIV performs complex division in real arithmetic +*> +*> a + i*b +*> p + i*q = --------- +*> c + i*d +*> +*> The algorithm is due to Michael Baudin and Robert L. Smith +*> and can be found in the paper +*> "A Robust Complex Division in Scilab" +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION +*> The scalars a, b, c, and d in the above expression. +*> \endverbatim +*> +*> \param[out] P +*> \verbatim +*> P is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION +*> The scalars p and q in the above expression. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date January 2013 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLADIV( A, B, C, D, P, Q ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2013 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, P, Q +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION BS + PARAMETER ( BS = 2.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) +* +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLADIV1 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + AA = A + BB = B + CC = C + DD = D + AB = MAX( ABS(A), ABS(B) ) + CD = MAX( ABS(C), ABS(D) ) + S = 1.0D0 + + OV = DLAMCH( 'Overflow threshold' ) + UN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Epsilon' ) + BE = BS / (EPS*EPS) + + IF( AB >= HALF*OV ) THEN + AA = HALF * AA + BB = HALF * BB + S = TWO * S + END IF + IF( CD >= HALF*OV ) THEN + CC = HALF * CC + DD = HALF * DD + S = HALF * S + END IF + IF( AB <= UN*BS/EPS ) THEN + AA = AA * BE + BB = BB * BE + S = S / BE + END IF + IF( CD <= UN*BS/EPS ) THEN + CC = CC * BE + DD = DD * BE + S = S * BE + END IF + IF( ABS( D ).LE.ABS( C ) ) THEN + CALL DLADIV1(AA, BB, CC, DD, P, Q) + ELSE + CALL DLADIV1(BB, AA, DD, CC, P, Q) + Q = -Q + END IF + P = P * S + Q = Q * S +* + RETURN +* +* End of DLADIV +* + END + +*> \ingroup doubleOTHERauxiliary + + + SUBROUTINE DLADIV1( A, B, C, D, P, Q ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2013 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, P, Q +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* +* .. Local Scalars .. + DOUBLE PRECISION R, T +* .. +* .. External Functions .. + DOUBLE PRECISION DLADIV2 + EXTERNAL DLADIV2 +* .. +* .. Executable Statements .. +* + R = D / C + T = ONE / (C + D * R) + P = DLADIV2(A, B, C, D, R, T) + A = -A + Q = DLADIV2(B, A, C, D, R, T) +* + RETURN +* +* End of DLADIV1 +* + END + +*> \ingroup doubleOTHERauxiliary + + DOUBLE PRECISION FUNCTION DLADIV2( A, B, C, D, R, T ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2013 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, R, T +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* +* .. Local Scalars .. + DOUBLE PRECISION BR +* .. +* .. Executable Statements .. +* + IF( R.NE.ZERO ) THEN + BR = B * R + IF( BR.NE.ZERO ) THEN + DLADIV2 = (A + BR) * T + ELSE + DLADIV2 = A * T + (B * T) * R + END IF + ELSE + DLADIV2 = (A + D * (B / C)) * T + END IF +* + RETURN +* +* End of DLADIV12 +* + END diff --git a/math/lapack/src/main/fortran/dlae2.f b/math/lapack/src/main/fortran/dlae2.f new file mode 100644 index 0000000000..ed77ff6dfe --- /dev/null +++ b/math/lapack/src/main/fortran/dlae2.f @@ -0,0 +1,185 @@ +*> \brief \b DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAE2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION A, B, C, RT1, RT2 +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION +*> The (1,1) element of the 2-by-2 matrix. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION +*> The (1,2) and (2,1) elements of the 2-by-2 matrix. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION +*> The (2,2) element of the 2-by-2 matrix. +*> \endverbatim +*> +*> \param[out] RT1 +*> \verbatim +*> RT1 is DOUBLE PRECISION +*> The eigenvalue of larger absolute value. +*> \endverbatim +*> +*> \param[out] RT2 +*> \verbatim +*> RT2 is DOUBLE PRECISION +*> The eigenvalue of smaller absolute value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, RT1, RT2 +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlaebz.f b/math/lapack/src/main/fortran/dlaebz.f new file mode 100644 index 0000000000..f36a82c59f --- /dev/null +++ b/math/lapack/src/main/fortran/dlaebz.f @@ -0,0 +1,649 @@ +*> \brief \b DLAEBZ computes the number of eigenvalues of a real symmetric tridiagonal matrix which are less than or equal to a given value, and performs other tasks required by the routine sstebz. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAEBZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, +* RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, +* NAB, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX +* DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * ) +* DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAEBZ contains the iteration loops which compute and use the +*> function N(w), which is the count of eigenvalues of a symmetric +*> tridiagonal matrix T less than or equal to its argument w. It +*> performs a choice of two types of loops: +*> +*> IJOB=1, followed by +*> IJOB=2: It takes as input a list of intervals and returns a list of +*> sufficiently small intervals whose union contains the same +*> eigenvalues as the union of the original intervals. +*> The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP. +*> The output interval (AB(j,1),AB(j,2)] will contain +*> eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT. +*> +*> IJOB=3: It performs a binary search in each input interval +*> (AB(j,1),AB(j,2)] for a point w(j) such that +*> N(w(j))=NVAL(j), and uses C(j) as the starting point of +*> the search. If such a w(j) is found, then on output +*> AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output +*> (AB(j,1),AB(j,2)] will be a small interval containing the +*> point where N(w) jumps through NVAL(j), unless that point +*> lies outside the initial interval. +*> +*> Note that the intervals are in all cases half-open intervals, +*> i.e., of the form (a,b] , which includes b but not a . +*> +*> To avoid underflow, the matrix should be scaled so that its largest +*> element is no greater than overflow**(1/2) * underflow**(1/4) +*> in absolute value. To assure the most accurate computation +*> of small eigenvalues, the matrix should be scaled to be +*> not much smaller than that, either. +*> +*> See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal +*> Matrix", Report CS41, Computer Science Dept., Stanford +*> University, July 21, 1966 +*> +*> Note: the arguments are, in general, *not* checked for unreasonable +*> values. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] IJOB +*> \verbatim +*> IJOB is INTEGER +*> Specifies what is to be done: +*> = 1: Compute NAB for the initial intervals. +*> = 2: Perform bisection iteration to find eigenvalues of T. +*> = 3: Perform bisection iteration to invert N(w), i.e., +*> to find a point which has a specified number of +*> eigenvalues of T to its left. +*> Other values will cause DLAEBZ to return with INFO=-1. +*> \endverbatim +*> +*> \param[in] NITMAX +*> \verbatim +*> NITMAX is INTEGER +*> The maximum number of "levels" of bisection to be +*> performed, i.e., an interval of width W will not be made +*> smaller than 2^(-NITMAX) * W. If not all intervals +*> have converged after NITMAX iterations, then INFO is set +*> to the number of non-converged intervals. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The dimension n of the tridiagonal matrix T. It must be at +*> least 1. +*> \endverbatim +*> +*> \param[in] MMAX +*> \verbatim +*> MMAX is INTEGER +*> The maximum number of intervals. If more than MMAX intervals +*> are generated, then DLAEBZ will quit with INFO=MMAX+1. +*> \endverbatim +*> +*> \param[in] MINP +*> \verbatim +*> MINP is INTEGER +*> The initial number of intervals. It may not be greater than +*> MMAX. +*> \endverbatim +*> +*> \param[in] NBMIN +*> \verbatim +*> NBMIN is INTEGER +*> The smallest number of intervals that should be processed +*> using a vector loop. If zero, then only the scalar loop +*> will be used. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The minimum (absolute) width of an interval. When an +*> interval is narrower than ABSTOL, or than RELTOL times the +*> larger (in magnitude) endpoint, then it is considered to be +*> sufficiently small, i.e., converged. This must be at least +*> zero. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION +*> The minimum relative width of an interval. When an interval +*> is narrower than ABSTOL, or than RELTOL times the larger (in +*> magnitude) endpoint, then it is considered to be +*> sufficiently small, i.e., converged. Note: this should +*> always be at least radix*machine epsilon. +*> \endverbatim +*> +*> \param[in] PIVMIN +*> \verbatim +*> PIVMIN is DOUBLE PRECISION +*> The minimum absolute value of a "pivot" in the Sturm +*> sequence loop. +*> This must be at least max |e(j)**2|*safe_min and at +*> least safe_min, where safe_min is at least +*> the smallest number that can divide one without overflow. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> The offdiagonal elements of the tridiagonal matrix T in +*> positions 1 through N-1. E(N) is arbitrary. +*> \endverbatim +*> +*> \param[in] E2 +*> \verbatim +*> E2 is DOUBLE PRECISION array, dimension (N) +*> The squares of the offdiagonal elements of the tridiagonal +*> matrix T. E2(N) is ignored. +*> \endverbatim +*> +*> \param[in,out] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (MINP) +*> If IJOB=1 or 2, not referenced. +*> If IJOB=3, the desired values of N(w). The elements of NVAL +*> will be reordered to correspond with the intervals in AB. +*> Thus, NVAL(j) on output will not, in general be the same as +*> NVAL(j) on input, but it will correspond with the interval +*> (AB(j,1),AB(j,2)] on output. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (MMAX,2) +*> The endpoints of the intervals. AB(j,1) is a(j), the left +*> endpoint of the j-th interval, and AB(j,2) is b(j), the +*> right endpoint of the j-th interval. The input intervals +*> will, in general, be modified, split, and reordered by the +*> calculation. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (MMAX) +*> If IJOB=1, ignored. +*> If IJOB=2, workspace. +*> If IJOB=3, then on input C(j) should be initialized to the +*> first search point in the binary search. +*> \endverbatim +*> +*> \param[out] MOUT +*> \verbatim +*> MOUT is INTEGER +*> If IJOB=1, the number of eigenvalues in the intervals. +*> If IJOB=2 or 3, the number of intervals output. +*> If IJOB=3, MOUT will equal MINP. +*> \endverbatim +*> +*> \param[in,out] NAB +*> \verbatim +*> NAB is INTEGER array, dimension (MMAX,2) +*> If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)). +*> If IJOB=2, then on input, NAB(i,j) should be set. It must +*> satisfy the condition: +*> N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)), +*> which means that in interval i only eigenvalues +*> NAB(i,1)+1,...,NAB(i,2) will be considered. Usually, +*> NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with +*> IJOB=1. +*> On output, NAB(i,j) will contain +*> max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of +*> the input interval that the output interval +*> (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the +*> the input values of NAB(k,1) and NAB(k,2). +*> If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)), +*> unless N(w) > NVAL(i) for all search points w , in which +*> case NAB(i,1) will not be modified, i.e., the output +*> value will be the same as the input value (modulo +*> reorderings -- see NVAL and AB), or unless N(w) < NVAL(i) +*> for all search points w , in which case NAB(i,2) will +*> not be modified. Normally, NAB should be set to some +*> distinctive value(s) before DLAEBZ is called. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MMAX) +*> Workspace. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MMAX) +*> Workspace. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: All intervals converged. +*> = 1--MMAX: The last INFO intervals did not converge. +*> = MMAX+1: More than MMAX intervals were generated. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> This routine is intended to be called only by other LAPACK +*> routines, thus the interface is less user-friendly. It is intended +*> for two purposes: +*> +*> (a) finding eigenvalues. In this case, DLAEBZ should have one or +*> more initial intervals set up in AB, and DLAEBZ should be called +*> with IJOB=1. This sets up NAB, and also counts the eigenvalues. +*> Intervals with no eigenvalues would usually be thrown out at +*> this point. Also, if not all the eigenvalues in an interval i +*> are desired, NAB(i,1) can be increased or NAB(i,2) decreased. +*> For example, set NAB(i,1)=NAB(i,2)-1 to get the largest +*> eigenvalue. DLAEBZ is then called with IJOB=2 and MMAX +*> no smaller than the value of MOUT returned by the call with +*> IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1 +*> through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the +*> tolerance specified by ABSTOL and RELTOL. +*> +*> (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l). +*> In this case, start with a Gershgorin interval (a,b). Set up +*> AB to contain 2 search intervals, both initially (a,b). One +*> NVAL element should contain f-1 and the other should contain l +*> , while C should contain a and b, resp. NAB(i,1) should be -1 +*> and NAB(i,2) should be N+1, to flag an error if the desired +*> interval does not lie in (a,b). DLAEBZ is then called with +*> IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals -- +*> j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while +*> if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r +*> >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and +*> N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and +*> w(l-r)=...=w(l+k) are handled similarly. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, + $ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, + $ NAB, WORK, IWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX + DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * ) + DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, TWO, HALF + PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0, + $ HALF = 1.0D0 / TWO ) +* .. +* .. Local Scalars .. + INTEGER ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL, + $ KLNEW + DOUBLE PRECISION TMP1, TMP2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* +* Check for Errors +* + INFO = 0 + IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN + INFO = -1 + RETURN + END IF +* +* Initialize NAB +* + IF( IJOB.EQ.1 ) THEN +* +* Compute the number of eigenvalues in the initial intervals. +* + MOUT = 0 + DO 30 JI = 1, MINP + DO 20 JP = 1, 2 + TMP1 = D( 1 ) - AB( JI, JP ) + IF( ABS( TMP1 ).LT.PIVMIN ) + $ TMP1 = -PIVMIN + NAB( JI, JP ) = 0 + IF( TMP1.LE.ZERO ) + $ NAB( JI, JP ) = 1 +* + DO 10 J = 2, N + TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP ) + IF( ABS( TMP1 ).LT.PIVMIN ) + $ TMP1 = -PIVMIN + IF( TMP1.LE.ZERO ) + $ NAB( JI, JP ) = NAB( JI, JP ) + 1 + 10 CONTINUE + 20 CONTINUE + MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 ) + 30 CONTINUE + RETURN + END IF +* +* Initialize for loop +* +* KF and KL have the following meaning: +* Intervals 1,...,KF-1 have converged. +* Intervals KF,...,KL still need to be refined. +* + KF = 1 + KL = MINP +* +* If IJOB=2, initialize C. +* If IJOB=3, use the user-supplied starting point. +* + IF( IJOB.EQ.2 ) THEN + DO 40 JI = 1, MINP + C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) ) + 40 CONTINUE + END IF +* +* Iteration loop +* + DO 130 JIT = 1, NITMAX +* +* Loop over intervals +* + IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN +* +* Begin of Parallel Version of the loop +* + DO 60 JI = KF, KL +* +* Compute N(c), the number of eigenvalues less than c +* + WORK( JI ) = D( 1 ) - C( JI ) + IWORK( JI ) = 0 + IF( WORK( JI ).LE.PIVMIN ) THEN + IWORK( JI ) = 1 + WORK( JI ) = MIN( WORK( JI ), -PIVMIN ) + END IF +* + DO 50 J = 2, N + WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI ) + IF( WORK( JI ).LE.PIVMIN ) THEN + IWORK( JI ) = IWORK( JI ) + 1 + WORK( JI ) = MIN( WORK( JI ), -PIVMIN ) + END IF + 50 CONTINUE + 60 CONTINUE +* + IF( IJOB.LE.2 ) THEN +* +* IJOB=2: Choose all intervals containing eigenvalues. +* + KLNEW = KL + DO 70 JI = KF, KL +* +* Insure that N(w) is monotone +* + IWORK( JI ) = MIN( NAB( JI, 2 ), + $ MAX( NAB( JI, 1 ), IWORK( JI ) ) ) +* +* Update the Queue -- add intervals if both halves +* contain eigenvalues. +* + IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN +* +* No eigenvalue in the upper interval: +* just use the lower interval. +* + AB( JI, 2 ) = C( JI ) +* + ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN +* +* No eigenvalue in the lower interval: +* just use the upper interval. +* + AB( JI, 1 ) = C( JI ) + ELSE + KLNEW = KLNEW + 1 + IF( KLNEW.LE.MMAX ) THEN +* +* Eigenvalue in both intervals -- add upper to +* queue. +* + AB( KLNEW, 2 ) = AB( JI, 2 ) + NAB( KLNEW, 2 ) = NAB( JI, 2 ) + AB( KLNEW, 1 ) = C( JI ) + NAB( KLNEW, 1 ) = IWORK( JI ) + AB( JI, 2 ) = C( JI ) + NAB( JI, 2 ) = IWORK( JI ) + ELSE + INFO = MMAX + 1 + END IF + END IF + 70 CONTINUE + IF( INFO.NE.0 ) + $ RETURN + KL = KLNEW + ELSE +* +* IJOB=3: Binary search. Keep only the interval containing +* w s.t. N(w) = NVAL +* + DO 80 JI = KF, KL + IF( IWORK( JI ).LE.NVAL( JI ) ) THEN + AB( JI, 1 ) = C( JI ) + NAB( JI, 1 ) = IWORK( JI ) + END IF + IF( IWORK( JI ).GE.NVAL( JI ) ) THEN + AB( JI, 2 ) = C( JI ) + NAB( JI, 2 ) = IWORK( JI ) + END IF + 80 CONTINUE + END IF +* + ELSE +* +* End of Parallel Version of the loop +* +* Begin of Serial Version of the loop +* + KLNEW = KL + DO 100 JI = KF, KL +* +* Compute N(w), the number of eigenvalues less than w +* + TMP1 = C( JI ) + TMP2 = D( 1 ) - TMP1 + ITMP1 = 0 + IF( TMP2.LE.PIVMIN ) THEN + ITMP1 = 1 + TMP2 = MIN( TMP2, -PIVMIN ) + END IF +* + DO 90 J = 2, N + TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1 + IF( TMP2.LE.PIVMIN ) THEN + ITMP1 = ITMP1 + 1 + TMP2 = MIN( TMP2, -PIVMIN ) + END IF + 90 CONTINUE +* + IF( IJOB.LE.2 ) THEN +* +* IJOB=2: Choose all intervals containing eigenvalues. +* +* Insure that N(w) is monotone +* + ITMP1 = MIN( NAB( JI, 2 ), + $ MAX( NAB( JI, 1 ), ITMP1 ) ) +* +* Update the Queue -- add intervals if both halves +* contain eigenvalues. +* + IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN +* +* No eigenvalue in the upper interval: +* just use the lower interval. +* + AB( JI, 2 ) = TMP1 +* + ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN +* +* No eigenvalue in the lower interval: +* just use the upper interval. +* + AB( JI, 1 ) = TMP1 + ELSE IF( KLNEW.LT.MMAX ) THEN +* +* Eigenvalue in both intervals -- add upper to queue. +* + KLNEW = KLNEW + 1 + AB( KLNEW, 2 ) = AB( JI, 2 ) + NAB( KLNEW, 2 ) = NAB( JI, 2 ) + AB( KLNEW, 1 ) = TMP1 + NAB( KLNEW, 1 ) = ITMP1 + AB( JI, 2 ) = TMP1 + NAB( JI, 2 ) = ITMP1 + ELSE + INFO = MMAX + 1 + RETURN + END IF + ELSE +* +* IJOB=3: Binary search. Keep only the interval +* containing w s.t. N(w) = NVAL +* + IF( ITMP1.LE.NVAL( JI ) ) THEN + AB( JI, 1 ) = TMP1 + NAB( JI, 1 ) = ITMP1 + END IF + IF( ITMP1.GE.NVAL( JI ) ) THEN + AB( JI, 2 ) = TMP1 + NAB( JI, 2 ) = ITMP1 + END IF + END IF + 100 CONTINUE + KL = KLNEW +* + END IF +* +* Check for convergence +* + KFNEW = KF + DO 110 JI = KF, KL + TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) ) + TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) ) + IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR. + $ NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN +* +* Converged -- Swap with position KFNEW, +* then increment KFNEW +* + IF( JI.GT.KFNEW ) THEN + TMP1 = AB( JI, 1 ) + TMP2 = AB( JI, 2 ) + ITMP1 = NAB( JI, 1 ) + ITMP2 = NAB( JI, 2 ) + AB( JI, 1 ) = AB( KFNEW, 1 ) + AB( JI, 2 ) = AB( KFNEW, 2 ) + NAB( JI, 1 ) = NAB( KFNEW, 1 ) + NAB( JI, 2 ) = NAB( KFNEW, 2 ) + AB( KFNEW, 1 ) = TMP1 + AB( KFNEW, 2 ) = TMP2 + NAB( KFNEW, 1 ) = ITMP1 + NAB( KFNEW, 2 ) = ITMP2 + IF( IJOB.EQ.3 ) THEN + ITMP1 = NVAL( JI ) + NVAL( JI ) = NVAL( KFNEW ) + NVAL( KFNEW ) = ITMP1 + END IF + END IF + KFNEW = KFNEW + 1 + END IF + 110 CONTINUE + KF = KFNEW +* +* Choose Midpoints +* + DO 120 JI = KF, KL + C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) ) + 120 CONTINUE +* +* If no more intervals to refine, quit. +* + IF( KF.GT.KL ) + $ GO TO 140 + 130 CONTINUE +* +* Converged +* + 140 CONTINUE + INFO = MAX( KL+1-KF, 0 ) + MOUT = KL +* + RETURN +* +* End of DLAEBZ +* + END diff --git a/math/lapack/src/main/fortran/dlaed0.f b/math/lapack/src/main/fortran/dlaed0.f new file mode 100644 index 0000000000..4e92da98ea --- /dev/null +++ b/math/lapack/src/main/fortran/dlaed0.f @@ -0,0 +1,434 @@ +*> \brief \b DLAED0 used by sstedc. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAED0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAED0 computes all eigenvalues and corresponding eigenvectors of a +*> symmetric tridiagonal matrix using the divide and conquer method. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ICOMPQ +*> \verbatim +*> ICOMPQ is INTEGER +*> = 0: Compute eigenvalues only. +*> = 1: Compute eigenvectors of original dense symmetric matrix +*> also. On entry, Q contains the orthogonal matrix used +*> to reduce the original matrix to tridiagonal form. +*> = 2: Compute eigenvalues and eigenvectors of tridiagonal +*> matrix. +*> \endverbatim +*> +*> \param[in] QSIZ +*> \verbatim +*> QSIZ is INTEGER +*> The dimension of the orthogonal matrix used to reduce +*> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The dimension of the symmetric tridiagonal matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the main diagonal of the tridiagonal matrix. +*> On exit, its eigenvalues. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The off-diagonal elements of the tridiagonal matrix. +*> On exit, E has been destroyed. +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ, N) +*> On entry, Q must contain an N-by-N orthogonal matrix. +*> If ICOMPQ = 0 Q is not referenced. +*> If ICOMPQ = 1 On entry, Q is a subset of the columns of the +*> orthogonal matrix used to reduce the full +*> matrix to tridiagonal form corresponding to +*> the subset of the full matrix which is being +*> decomposed at this time. +*> If ICOMPQ = 2 On entry, Q will be the identity matrix. +*> On exit, Q contains the eigenvectors of the +*> tridiagonal matrix. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. If eigenvectors are +*> desired, then LDQ >= max(1,N). In any case, LDQ >= 1. +*> \endverbatim +*> +*> \param[out] QSTORE +*> \verbatim +*> QSTORE is DOUBLE PRECISION array, dimension (LDQS, N) +*> Referenced only when ICOMPQ = 1. Used to store parts of +*> the eigenvector matrix when the updating matrix multiplies +*> take place. +*> \endverbatim +*> +*> \param[in] LDQS +*> \verbatim +*> LDQS is INTEGER +*> The leading dimension of the array QSTORE. If ICOMPQ = 1, +*> then LDQS >= max(1,N). In any case, LDQS >= 1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, +*> If ICOMPQ = 0 or 1, the dimension of WORK must be at least +*> 1 + 3*N + 2*N*lg N + 3*N**2 +*> ( lg( N ) = smallest integer k +*> such that 2^k >= N ) +*> If ICOMPQ = 2, the dimension of WORK must be at least +*> 4*N + N**2. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, +*> If ICOMPQ = 0 or 1, the dimension of IWORK must be at least +*> 6 + 6*N + 5*N*lg N. +*> ( lg( N ) = smallest integer k +*> such that 2^k >= N ) +*> If ICOMPQ = 2, the dimension of IWORK must be at least +*> 3 + 5*N. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: The algorithm failed to compute an eigenvalue while +*> working on the submatrix lying in rows and columns +*> INFO/(N+1) through mod(INFO,N+1). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Jeff Rutter, Computer Science Division, University of California +*> at Berkeley, USA +* +* ===================================================================== + SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, + $ WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0 ) +* .. +* .. Local Scalars .. + INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM, + $ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM, + $ J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1, + $ SPM2, SUBMAT, SUBPBS, TLVLS + DOUBLE PRECISION TEMP +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLACPY, DLAED1, DLAED7, DSTEQR, + $ XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN + INFO = -1 + ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAED0', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + SMLSIZ = ILAENV( 9, 'DLAED0', ' ', 0, 0, 0, 0 ) +* +* Determine the size and placement of the submatrices, and save in +* the leading elements of IWORK. +* + IWORK( 1 ) = N + SUBPBS = 1 + TLVLS = 0 + 10 CONTINUE + IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN + DO 20 J = SUBPBS, 1, -1 + IWORK( 2*J ) = ( IWORK( J )+1 ) / 2 + IWORK( 2*J-1 ) = IWORK( J ) / 2 + 20 CONTINUE + TLVLS = TLVLS + 1 + SUBPBS = 2*SUBPBS + GO TO 10 + END IF + DO 30 J = 2, SUBPBS + IWORK( J ) = IWORK( J ) + IWORK( J-1 ) + 30 CONTINUE +* +* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 +* using rank-1 modifications (cuts). +* + SPM1 = SUBPBS - 1 + DO 40 I = 1, SPM1 + SUBMAT = IWORK( I ) + 1 + SMM1 = SUBMAT - 1 + D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) ) + D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) ) + 40 CONTINUE +* + INDXQ = 4*N + 3 + IF( ICOMPQ.NE.2 ) THEN +* +* Set up workspaces for eigenvalues only/accumulate new vectors +* routine +* + TEMP = LOG( DBLE( N ) ) / LOG( TWO ) + LGN = INT( TEMP ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IPRMPT = INDXQ + N + 1 + IPERM = IPRMPT + N*LGN + IQPTR = IPERM + N*LGN + IGIVPT = IQPTR + N + 2 + IGIVCL = IGIVPT + N*LGN +* + IGIVNM = 1 + IQ = IGIVNM + 2*N*LGN + IWREM = IQ + N**2 + 1 +* +* Initialize pointers +* + DO 50 I = 0, SUBPBS + IWORK( IPRMPT+I ) = 1 + IWORK( IGIVPT+I ) = 1 + 50 CONTINUE + IWORK( IQPTR ) = 1 + END IF +* +* Solve each submatrix eigenproblem at the bottom of the divide and +* conquer tree. +* + CURR = 0 + DO 70 I = 0, SPM1 + IF( I.EQ.0 ) THEN + SUBMAT = 1 + MATSIZ = IWORK( 1 ) + ELSE + SUBMAT = IWORK( I ) + 1 + MATSIZ = IWORK( I+1 ) - IWORK( I ) + END IF + IF( ICOMPQ.EQ.2 ) THEN + CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ), + $ Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO ) + IF( INFO.NE.0 ) + $ GO TO 130 + ELSE + CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ), + $ WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK, + $ INFO ) + IF( INFO.NE.0 ) + $ GO TO 130 + IF( ICOMPQ.EQ.1 ) THEN + CALL DGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE, + $ Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+ + $ CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ), + $ LDQS ) + END IF + IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2 + CURR = CURR + 1 + END IF + K = 1 + DO 60 J = SUBMAT, IWORK( I+1 ) + IWORK( INDXQ+J ) = K + K = K + 1 + 60 CONTINUE + 70 CONTINUE +* +* Successively merge eigensystems of adjacent submatrices +* into eigensystem for the corresponding larger matrix. +* +* while ( SUBPBS > 1 ) +* + CURLVL = 1 + 80 CONTINUE + IF( SUBPBS.GT.1 ) THEN + SPM2 = SUBPBS - 2 + DO 90 I = 0, SPM2, 2 + IF( I.EQ.0 ) THEN + SUBMAT = 1 + MATSIZ = IWORK( 2 ) + MSD2 = IWORK( 1 ) + CURPRB = 0 + ELSE + SUBMAT = IWORK( I ) + 1 + MATSIZ = IWORK( I+2 ) - IWORK( I ) + MSD2 = MATSIZ / 2 + CURPRB = CURPRB + 1 + END IF +* +* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) +* into an eigensystem of size MATSIZ. +* DLAED1 is used only for the full eigensystem of a tridiagonal +* matrix. +* DLAED7 handles the cases in which eigenvalues only or eigenvalues +* and eigenvectors of a full symmetric matrix (which was reduced to +* tridiagonal form) are desired. +* + IF( ICOMPQ.EQ.2 ) THEN + CALL DLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ), + $ LDQ, IWORK( INDXQ+SUBMAT ), + $ E( SUBMAT+MSD2-1 ), MSD2, WORK, + $ IWORK( SUBPBS+1 ), INFO ) + ELSE + CALL DLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB, + $ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS, + $ IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ), + $ MSD2, WORK( IQ ), IWORK( IQPTR ), + $ IWORK( IPRMPT ), IWORK( IPERM ), + $ IWORK( IGIVPT ), IWORK( IGIVCL ), + $ WORK( IGIVNM ), WORK( IWREM ), + $ IWORK( SUBPBS+1 ), INFO ) + END IF + IF( INFO.NE.0 ) + $ GO TO 130 + IWORK( I / 2+1 ) = IWORK( I+2 ) + 90 CONTINUE + SUBPBS = SUBPBS / 2 + CURLVL = CURLVL + 1 + GO TO 80 + END IF +* +* end while +* +* Re-merge the eigenvalues/vectors which were deflated at the final +* merge step. +* + IF( ICOMPQ.EQ.1 ) THEN + DO 100 I = 1, N + J = IWORK( INDXQ+I ) + WORK( I ) = D( J ) + CALL DCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 ) + 100 CONTINUE + CALL DCOPY( N, WORK, 1, D, 1 ) + ELSE IF( ICOMPQ.EQ.2 ) THEN + DO 110 I = 1, N + J = IWORK( INDXQ+I ) + WORK( I ) = D( J ) + CALL DCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 ) + 110 CONTINUE + CALL DCOPY( N, WORK, 1, D, 1 ) + CALL DLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ ) + ELSE + DO 120 I = 1, N + J = IWORK( INDXQ+I ) + WORK( I ) = D( J ) + 120 CONTINUE + CALL DCOPY( N, WORK, 1, D, 1 ) + END IF + GO TO 140 +* + 130 CONTINUE + INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1 +* + 140 CONTINUE + RETURN +* +* End of DLAED0 +* + END diff --git a/math/lapack/src/main/fortran/dlaed1.f b/math/lapack/src/main/fortran/dlaed1.f new file mode 100644 index 0000000000..30e71fa241 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaed1.f @@ -0,0 +1,274 @@ +*> \brief \b DLAED1 used by sstedc. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is tridiagonal. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAED1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER CUTPNT, INFO, LDQ, N +* DOUBLE PRECISION RHO +* .. +* .. Array Arguments .. +* INTEGER INDXQ( * ), IWORK( * ) +* DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAED1 computes the updated eigensystem of a diagonal +*> matrix after modification by a rank-one symmetric matrix. This +*> routine is used only for the eigenproblem which requires all +*> eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles +*> the case in which eigenvalues only or eigenvalues and eigenvectors +*> of a full symmetric matrix (which was reduced to tridiagonal form) +*> are desired. +*> +*> T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out) +*> +*> where Z = Q**T*u, u is a vector of length N with ones in the +*> CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. +*> +*> The eigenvectors of the original matrix are stored in Q, and the +*> eigenvalues are in D. The algorithm consists of three stages: +*> +*> The first stage consists of deflating the size of the problem +*> when there are multiple eigenvalues or if there is a zero in +*> the Z vector. For each such occurrence the dimension of the +*> secular equation problem is reduced by one. This stage is +*> performed by the routine DLAED2. +*> +*> The second stage consists of calculating the updated +*> eigenvalues. This is done by finding the roots of the secular +*> equation via the routine DLAED4 (as called by DLAED3). +*> This routine also calculates the eigenvectors of the current +*> problem. +*> +*> The final stage consists of computing the updated eigenvectors +*> directly using the updated eigenvalues. The eigenvectors for +*> the current problem are multiplied with the eigenvectors from +*> the overall problem. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The dimension of the symmetric tridiagonal matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the eigenvalues of the rank-1-perturbed matrix. +*> On exit, the eigenvalues of the repaired matrix. +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ,N) +*> On entry, the eigenvectors of the rank-1-perturbed matrix. +*> On exit, the eigenvectors of the repaired tridiagonal matrix. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] INDXQ +*> \verbatim +*> INDXQ is INTEGER array, dimension (N) +*> On entry, the permutation which separately sorts the two +*> subproblems in D into ascending order. +*> On exit, the permutation which will reintegrate the +*> subproblems back into sorted order, +*> i.e. D( INDXQ( I = 1, N ) ) will be in ascending order. +*> \endverbatim +*> +*> \param[in] RHO +*> \verbatim +*> RHO is DOUBLE PRECISION +*> The subdiagonal entry used to create the rank-1 modification. +*> \endverbatim +*> +*> \param[in] CUTPNT +*> \verbatim +*> CUTPNT is INTEGER +*> The location of the last eigenvalue in the leading sub-matrix. +*> min(1,N) <= CUTPNT <= N/2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N + N**2) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (4*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = 1, an eigenvalue did not converge +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup auxOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Jeff Rutter, Computer Science Division, University of California +*> at Berkeley, USA \n +*> Modified by Francoise Tisseur, University of Tennessee +*> +* ===================================================================== + SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER CUTPNT, INFO, LDQ, N + DOUBLE PRECISION RHO +* .. +* .. Array Arguments .. + INTEGER INDXQ( * ), IWORK( * ) + DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS, + $ IW, IZ, K, N1, N2, ZPP1 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAED1', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* The following values are integer pointers which indicate +* the portion of the workspace +* used by a particular array in DLAED2 and DLAED3. +* + IZ = 1 + IDLMDA = IZ + N + IW = IDLMDA + N + IQ2 = IW + N +* + INDX = 1 + INDXC = INDX + N + COLTYP = INDXC + N + INDXP = COLTYP + N +* +* +* Form the z-vector which consists of the last row of Q_1 and the +* first row of Q_2. +* + CALL DCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 ) + ZPP1 = CUTPNT + 1 + CALL DCOPY( N-CUTPNT, Q( ZPP1, ZPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 ) +* +* Deflate eigenvalues. +* + CALL DLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ), + $ WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ), + $ IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ), + $ IWORK( COLTYP ), INFO ) +* + IF( INFO.NE.0 ) + $ GO TO 20 +* +* Solve Secular Equation. +* + IF( K.NE.0 ) THEN + IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT + + $ ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2 + CALL DLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ), + $ WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ), + $ WORK( IW ), WORK( IS ), INFO ) + IF( INFO.NE.0 ) + $ GO TO 20 +* +* Prepare the INDXQ sorting permutation. +* + N1 = K + N2 = N - K + CALL DLAMRG( N1, N2, D, 1, -1, INDXQ ) + ELSE + DO 10 I = 1, N + INDXQ( I ) = I + 10 CONTINUE + END IF +* + 20 CONTINUE + RETURN +* +* End of DLAED1 +* + END diff --git a/math/lapack/src/main/fortran/dlaed2.f b/math/lapack/src/main/fortran/dlaed2.f new file mode 100644 index 0000000000..fbcc87a880 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaed2.f @@ -0,0 +1,539 @@ +*> \brief \b DLAED2 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original matrix is tridiagonal. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAED2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, +* Q2, INDX, INDXC, INDXP, COLTYP, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDQ, N, N1 +* DOUBLE PRECISION RHO +* .. +* .. Array Arguments .. +* INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ), +* $ INDXQ( * ) +* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), +* $ W( * ), Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAED2 merges the two sets of eigenvalues together into a single +*> sorted set. Then it tries to deflate the size of the problem. +*> There are two ways in which deflation can occur: when two or more +*> eigenvalues are close together or if there is a tiny entry in the +*> Z vector. For each such occurrence the order of the related secular +*> equation problem is reduced by one. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> The number of non-deflated eigenvalues, and the order of the +*> related secular equation. 0 <= K <=N. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The dimension of the symmetric tridiagonal matrix. N >= 0. +*> \endverbatim +*> +*> \param[in] N1 +*> \verbatim +*> N1 is INTEGER +*> The location of the last eigenvalue in the leading sub-matrix. +*> min(1,N) <= N1 <= N/2. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, D contains the eigenvalues of the two submatrices to +*> be combined. +*> On exit, D contains the trailing (N-K) updated eigenvalues +*> (those which were deflated) sorted into increasing order. +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ, N) +*> On entry, Q contains the eigenvectors of two submatrices in +*> the two square blocks with corners at (1,1), (N1,N1) +*> and (N1+1, N1+1), (N,N). +*> On exit, Q contains the trailing (N-K) updated eigenvectors +*> (those which were deflated) in its last N-K columns. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] INDXQ +*> \verbatim +*> INDXQ is INTEGER array, dimension (N) +*> The permutation which separately sorts the two sub-problems +*> in D into ascending order. Note that elements in the second +*> half of this permutation must first have N1 added to their +*> values. Destroyed on exit. +*> \endverbatim +*> +*> \param[in,out] RHO +*> \verbatim +*> RHO is DOUBLE PRECISION +*> On entry, the off-diagonal element associated with the rank-1 +*> cut which originally split the two submatrices which are now +*> being recombined. +*> On exit, RHO has been modified to the value required by +*> DLAED3. +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (N) +*> On entry, Z contains the updating vector (the last +*> row of the first sub-eigenvector matrix and the first row of +*> the second sub-eigenvector matrix). +*> On exit, the contents of Z have been destroyed by the updating +*> process. +*> \endverbatim +*> +*> \param[out] DLAMDA +*> \verbatim +*> DLAMDA is DOUBLE PRECISION array, dimension (N) +*> A copy of the first K eigenvalues which will be used by +*> DLAED3 to form the secular equation. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first k values of the final deflation-altered z-vector +*> which will be passed to DLAED3. +*> \endverbatim +*> +*> \param[out] Q2 +*> \verbatim +*> Q2 is DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2) +*> A copy of the first K eigenvectors which will be used by +*> DLAED3 in a matrix multiply (DGEMM) to solve for the new +*> eigenvectors. +*> \endverbatim +*> +*> \param[out] INDX +*> \verbatim +*> INDX is INTEGER array, dimension (N) +*> The permutation used to sort the contents of DLAMDA into +*> ascending order. +*> \endverbatim +*> +*> \param[out] INDXC +*> \verbatim +*> INDXC is INTEGER array, dimension (N) +*> The permutation used to arrange the columns of the deflated +*> Q matrix into three groups: the first group contains non-zero +*> elements only at and above N1, the second contains +*> non-zero elements only below N1, and the third is dense. +*> \endverbatim +*> +*> \param[out] INDXP +*> \verbatim +*> INDXP is INTEGER array, dimension (N) +*> The permutation used to place deflated values of D at the end +*> of the array. INDXP(1:K) points to the nondeflated D-values +*> and INDXP(K+1:N) points to the deflated eigenvalues. +*> \endverbatim +*> +*> \param[out] COLTYP +*> \verbatim +*> COLTYP is INTEGER array, dimension (N) +*> During execution, a label which will indicate which of the +*> following types a column in the Q2 matrix is: +*> 1 : non-zero in the upper half only; +*> 2 : dense; +*> 3 : non-zero in the lower half only; +*> 4 : deflated. +*> On exit, COLTYP(i) is the number of columns of type i, +*> for i=1 to 4 only. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Jeff Rutter, Computer Science Division, University of California +*> at Berkeley, USA \n +*> Modified by Francoise Tisseur, University of Tennessee +*> +* ===================================================================== + SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, + $ Q2, INDX, INDXC, INDXP, COLTYP, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDQ, N, N1 + DOUBLE PRECISION RHO +* .. +* .. Array Arguments .. + INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ), + $ INDXQ( * ) + DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), + $ W( * ), Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT + PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0, + $ TWO = 2.0D0, EIGHT = 8.0D0 ) +* .. +* .. Local Arrays .. + INTEGER CTOT( 4 ), PSM( 4 ) +* .. +* .. Local Scalars .. + INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1, + $ N2, NJ, PJ + DOUBLE PRECISION C, EPS, S, T, TAU, TOL +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL IDAMAX, DLAMCH, DLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAED2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + N2 = N - N1 + N1P1 = N1 + 1 +* + IF( RHO.LT.ZERO ) THEN + CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) + END IF +* +* Normalize z so that norm(z) = 1. Since z is the concatenation of +* two normalized vectors, norm2(z) = sqrt(2). +* + T = ONE / SQRT( TWO ) + CALL DSCAL( N, T, Z, 1 ) +* +* RHO = ABS( norm(z)**2 * RHO ) +* + RHO = ABS( TWO*RHO ) +* +* Sort the eigenvalues into increasing order +* + DO 10 I = N1P1, N + INDXQ( I ) = INDXQ( I ) + N1 + 10 CONTINUE +* +* re-integrate the deflated parts from the last pass +* + DO 20 I = 1, N + DLAMDA( I ) = D( INDXQ( I ) ) + 20 CONTINUE + CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDXC ) + DO 30 I = 1, N + INDX( I ) = INDXQ( INDXC( I ) ) + 30 CONTINUE +* +* Calculate the allowable deflation tolerance +* + IMAX = IDAMAX( N, Z, 1 ) + JMAX = IDAMAX( N, D, 1 ) + EPS = DLAMCH( 'Epsilon' ) + TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) ) +* +* If the rank-1 modifier is small enough, no more needs to be done +* except to reorganize Q so that its columns correspond with the +* elements in D. +* + IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN + K = 0 + IQ2 = 1 + DO 40 J = 1, N + I = INDX( J ) + CALL DCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 ) + DLAMDA( J ) = D( I ) + IQ2 = IQ2 + N + 40 CONTINUE + CALL DLACPY( 'A', N, N, Q2, N, Q, LDQ ) + CALL DCOPY( N, DLAMDA, 1, D, 1 ) + GO TO 190 + END IF +* +* If there are multiple eigenvalues then the problem deflates. Here +* the number of equal eigenvalues are found. As each equal +* eigenvalue is found, an elementary reflector is computed to rotate +* the corresponding eigensubspace so that the corresponding +* components of Z are zero in this new basis. +* + DO 50 I = 1, N1 + COLTYP( I ) = 1 + 50 CONTINUE + DO 60 I = N1P1, N + COLTYP( I ) = 3 + 60 CONTINUE +* +* + K = 0 + K2 = N + 1 + DO 70 J = 1, N + NJ = INDX( J ) + IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN +* +* Deflate due to small z component. +* + K2 = K2 - 1 + COLTYP( NJ ) = 4 + INDXP( K2 ) = NJ + IF( J.EQ.N ) + $ GO TO 100 + ELSE + PJ = NJ + GO TO 80 + END IF + 70 CONTINUE + 80 CONTINUE + J = J + 1 + NJ = INDX( J ) + IF( J.GT.N ) + $ GO TO 100 + IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN +* +* Deflate due to small z component. +* + K2 = K2 - 1 + COLTYP( NJ ) = 4 + INDXP( K2 ) = NJ + ELSE +* +* Check if eigenvalues are close enough to allow deflation. +* + S = Z( PJ ) + C = Z( NJ ) +* +* Find sqrt(a**2+b**2) without overflow or +* destructive underflow. +* + TAU = DLAPY2( C, S ) + T = D( NJ ) - D( PJ ) + C = C / TAU + S = -S / TAU + IF( ABS( T*C*S ).LE.TOL ) THEN +* +* Deflation is possible. +* + Z( NJ ) = TAU + Z( PJ ) = ZERO + IF( COLTYP( NJ ).NE.COLTYP( PJ ) ) + $ COLTYP( NJ ) = 2 + COLTYP( PJ ) = 4 + CALL DROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S ) + T = D( PJ )*C**2 + D( NJ )*S**2 + D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2 + D( PJ ) = T + K2 = K2 - 1 + I = 1 + 90 CONTINUE + IF( K2+I.LE.N ) THEN + IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN + INDXP( K2+I-1 ) = INDXP( K2+I ) + INDXP( K2+I ) = PJ + I = I + 1 + GO TO 90 + ELSE + INDXP( K2+I-1 ) = PJ + END IF + ELSE + INDXP( K2+I-1 ) = PJ + END IF + PJ = NJ + ELSE + K = K + 1 + DLAMDA( K ) = D( PJ ) + W( K ) = Z( PJ ) + INDXP( K ) = PJ + PJ = NJ + END IF + END IF + GO TO 80 + 100 CONTINUE +* +* Record the last eigenvalue. +* + K = K + 1 + DLAMDA( K ) = D( PJ ) + W( K ) = Z( PJ ) + INDXP( K ) = PJ +* +* Count up the total number of the various types of columns, then +* form a permutation which positions the four column types into +* four uniform groups (although one or more of these groups may be +* empty). +* + DO 110 J = 1, 4 + CTOT( J ) = 0 + 110 CONTINUE + DO 120 J = 1, N + CT = COLTYP( J ) + CTOT( CT ) = CTOT( CT ) + 1 + 120 CONTINUE +* +* PSM(*) = Position in SubMatrix (of types 1 through 4) +* + PSM( 1 ) = 1 + PSM( 2 ) = 1 + CTOT( 1 ) + PSM( 3 ) = PSM( 2 ) + CTOT( 2 ) + PSM( 4 ) = PSM( 3 ) + CTOT( 3 ) + K = N - CTOT( 4 ) +* +* Fill out the INDXC array so that the permutation which it induces +* will place all type-1 columns first, all type-2 columns next, +* then all type-3's, and finally all type-4's. +* + DO 130 J = 1, N + JS = INDXP( J ) + CT = COLTYP( JS ) + INDX( PSM( CT ) ) = JS + INDXC( PSM( CT ) ) = J + PSM( CT ) = PSM( CT ) + 1 + 130 CONTINUE +* +* Sort the eigenvalues and corresponding eigenvectors into DLAMDA +* and Q2 respectively. The eigenvalues/vectors which were not +* deflated go into the first K slots of DLAMDA and Q2 respectively, +* while those which were deflated go into the last N - K slots. +* + I = 1 + IQ1 = 1 + IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1 + DO 140 J = 1, CTOT( 1 ) + JS = INDX( I ) + CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 ) + Z( I ) = D( JS ) + I = I + 1 + IQ1 = IQ1 + N1 + 140 CONTINUE +* + DO 150 J = 1, CTOT( 2 ) + JS = INDX( I ) + CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 ) + CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 ) + Z( I ) = D( JS ) + I = I + 1 + IQ1 = IQ1 + N1 + IQ2 = IQ2 + N2 + 150 CONTINUE +* + DO 160 J = 1, CTOT( 3 ) + JS = INDX( I ) + CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 ) + Z( I ) = D( JS ) + I = I + 1 + IQ2 = IQ2 + N2 + 160 CONTINUE +* + IQ1 = IQ2 + DO 170 J = 1, CTOT( 4 ) + JS = INDX( I ) + CALL DCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 ) + IQ2 = IQ2 + N + Z( I ) = D( JS ) + I = I + 1 + 170 CONTINUE +* +* The deflated eigenvalues and their corresponding vectors go back +* into the last N - K slots of D and Q respectively. +* + IF( K.LT.N ) THEN + CALL DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, + $ Q( 1, K+1 ), LDQ ) + CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 ) + END IF +* +* Copy CTOT into COLTYP for referencing in DLAED3. +* + DO 180 J = 1, 4 + COLTYP( J ) = CTOT( J ) + 180 CONTINUE +* + 190 CONTINUE + RETURN +* +* End of DLAED2 +* + END diff --git a/math/lapack/src/main/fortran/dlaed3.f b/math/lapack/src/main/fortran/dlaed3.f new file mode 100644 index 0000000000..4e62b31439 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaed3.f @@ -0,0 +1,353 @@ +*> \brief \b DLAED3 used by sstedc. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is tridiagonal. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAED3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, +* CTOT, W, S, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDQ, N, N1 +* DOUBLE PRECISION RHO +* .. +* .. Array Arguments .. +* INTEGER CTOT( * ), INDX( * ) +* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), +* $ S( * ), W( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAED3 finds the roots of the secular equation, as defined by the +*> values in D, W, and RHO, between 1 and K. It makes the +*> appropriate calls to DLAED4 and then updates the eigenvectors by +*> multiplying the matrix of eigenvectors of the pair of eigensystems +*> being combined by the matrix of eigenvectors of the K-by-K system +*> which is solved here. +*> +*> This code makes very mild assumptions about floating point +*> arithmetic. It will work on machines with a guard digit in +*> add/subtract, or on those binary machines without guard digits +*> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. +*> It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of terms in the rational function to be solved by +*> DLAED4. K >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns in the Q matrix. +*> N >= K (deflation may result in N>K). +*> \endverbatim +*> +*> \param[in] N1 +*> \verbatim +*> N1 is INTEGER +*> The location of the last eigenvalue in the leading submatrix. +*> min(1,N) <= N1 <= N/2. +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> D(I) contains the updated eigenvalues for +*> 1 <= I <= K. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ,N) +*> Initially the first K columns are used as workspace. +*> On output the columns 1 to K contain +*> the updated eigenvectors. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= max(1,N). +*> \endverbatim +*> +*> \param[in] RHO +*> \verbatim +*> RHO is DOUBLE PRECISION +*> The value of the parameter in the rank one update equation. +*> RHO >= 0 required. +*> \endverbatim +*> +*> \param[in,out] DLAMDA +*> \verbatim +*> DLAMDA is DOUBLE PRECISION array, dimension (K) +*> The first K elements of this array contain the old roots +*> of the deflated updating problem. These are the poles +*> of the secular equation. May be changed on output by +*> having lowest order bit set to zero on Cray X-MP, Cray Y-MP, +*> Cray-2, or Cray C-90, as described above. +*> \endverbatim +*> +*> \param[in] Q2 +*> \verbatim +*> Q2 is DOUBLE PRECISION array, dimension (LDQ2, N) +*> The first K columns of this matrix contain the non-deflated +*> eigenvectors for the split problem. +*> \endverbatim +*> +*> \param[in] INDX +*> \verbatim +*> INDX is INTEGER array, dimension (N) +*> The permutation used to arrange the columns of the deflated +*> Q matrix into three groups (see DLAED2). +*> The rows of the eigenvectors found by DLAED4 must be likewise +*> permuted before the matrix multiply can take place. +*> \endverbatim +*> +*> \param[in] CTOT +*> \verbatim +*> CTOT is INTEGER array, dimension (4) +*> A count of the total number of the various types of columns +*> in Q, as described in INDX. The fourth column type is any +*> column which has been deflated. +*> \endverbatim +*> +*> \param[in,out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (K) +*> The first K elements of this array contain the components +*> of the deflation-adjusted updating vector. Destroyed on +*> output. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N1 + 1)*K +*> Will contain the eigenvectors of the repaired matrix which +*> will be multiplied by the previously accumulated eigenvectors +*> to update the system. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = 1, an eigenvalue did not converge +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Jeff Rutter, Computer Science Division, University of California +*> at Berkeley, USA \n +*> Modified by Francoise Tisseur, University of Tennessee +*> +* ===================================================================== + SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, + $ CTOT, W, S, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDQ, N, N1 + DOUBLE PRECISION RHO +* .. +* .. Array Arguments .. + INTEGER CTOT( * ), INDX( * ) + DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), + $ S( * ), W( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I, II, IQ2, J, N12, N2, N23 + DOUBLE PRECISION TEMP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3, DNRM2 + EXTERNAL DLAMC3, DNRM2 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLACPY, DLAED4, DLASET, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( K.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.K ) THEN + INFO = -2 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAED3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( K.EQ.0 ) + $ RETURN +* +* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can +* be computed with high relative accuracy (barring over/underflow). +* This is a problem on machines without a guard digit in +* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). +* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), +* which on any of these machines zeros out the bottommost +* bit of DLAMDA(I) if it is 1; this makes the subsequent +* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation +* occurs. On binary machines with a guard digit (almost all +* machines) it does not change DLAMDA(I) at all. On hexadecimal +* and decimal machines with a guard digit, it slightly +* changes the bottommost bits of DLAMDA(I). It does not account +* for hexadecimal or decimal machines without guard digits +* (we know of none). We use a subroutine call to compute +* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating +* this code. +* + DO 10 I = 1, K + DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I ) + 10 CONTINUE +* + DO 20 J = 1, K + CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO ) +* +* If the zero finder fails, the computation is terminated. +* + IF( INFO.NE.0 ) + $ GO TO 120 + 20 CONTINUE +* + IF( K.EQ.1 ) + $ GO TO 110 + IF( K.EQ.2 ) THEN + DO 30 J = 1, K + W( 1 ) = Q( 1, J ) + W( 2 ) = Q( 2, J ) + II = INDX( 1 ) + Q( 1, J ) = W( II ) + II = INDX( 2 ) + Q( 2, J ) = W( II ) + 30 CONTINUE + GO TO 110 + END IF +* +* Compute updated W. +* + CALL DCOPY( K, W, 1, S, 1 ) +* +* Initialize W(I) = Q(I,I) +* + CALL DCOPY( K, Q, LDQ+1, W, 1 ) + DO 60 J = 1, K + DO 40 I = 1, J - 1 + W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) + 40 CONTINUE + DO 50 I = J + 1, K + W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) + 50 CONTINUE + 60 CONTINUE + DO 70 I = 1, K + W( I ) = SIGN( SQRT( -W( I ) ), S( I ) ) + 70 CONTINUE +* +* Compute eigenvectors of the modified rank-1 modification. +* + DO 100 J = 1, K + DO 80 I = 1, K + S( I ) = W( I ) / Q( I, J ) + 80 CONTINUE + TEMP = DNRM2( K, S, 1 ) + DO 90 I = 1, K + II = INDX( I ) + Q( I, J ) = S( II ) / TEMP + 90 CONTINUE + 100 CONTINUE +* +* Compute the updated eigenvectors. +* + 110 CONTINUE +* + N2 = N - N1 + N12 = CTOT( 1 ) + CTOT( 2 ) + N23 = CTOT( 2 ) + CTOT( 3 ) +* + CALL DLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 ) + IQ2 = N1*N12 + 1 + IF( N23.NE.0 ) THEN + CALL DGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23, + $ ZERO, Q( N1+1, 1 ), LDQ ) + ELSE + CALL DLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ ) + END IF +* + CALL DLACPY( 'A', N12, K, Q, LDQ, S, N12 ) + IF( N12.NE.0 ) THEN + CALL DGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q, + $ LDQ ) + ELSE + CALL DLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ ) + END IF +* +* + 120 CONTINUE + RETURN +* +* End of DLAED3 +* + END diff --git a/math/lapack/src/main/fortran/dlaed4.f b/math/lapack/src/main/fortran/dlaed4.f new file mode 100644 index 0000000000..e7dc839df5 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaed4.f @@ -0,0 +1,917 @@ +*> \brief \b DLAED4 used by sstedc. Finds a single root of the secular equation. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAED4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) +* +* .. Scalar Arguments .. +* INTEGER I, INFO, N +* DOUBLE PRECISION DLAM, RHO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), DELTA( * ), Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This subroutine computes the I-th updated eigenvalue of a symmetric +*> rank-one modification to a diagonal matrix whose elements are +*> given in the array d, and that +*> +*> D(i) < D(j) for i < j +*> +*> and that RHO > 0. This is arranged by the calling routine, and is +*> no loss in generality. The rank-one modified system is thus +*> +*> diag( D ) + RHO * Z * Z_transpose. +*> +*> where we assume the Euclidean norm of Z is 1. +*> +*> The method consists of approximating the rational functions in the +*> secular equation by simpler interpolating rational functions. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The length of all arrays. +*> \endverbatim +*> +*> \param[in] I +*> \verbatim +*> I is INTEGER +*> The index of the eigenvalue to be computed. 1 <= I <= N. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The original eigenvalues. It is assumed that they are in +*> order, D(I) < D(J) for I < J. +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (N) +*> The components of the updating vector. +*> \endverbatim +*> +*> \param[out] DELTA +*> \verbatim +*> DELTA is DOUBLE PRECISION array, dimension (N) +*> If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th +*> component. If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5 +*> for detail. The vector DELTA contains the information necessary +*> to construct the eigenvectors by DLAED3 and DLAED9. +*> \endverbatim +*> +*> \param[in] RHO +*> \verbatim +*> RHO is DOUBLE PRECISION +*> The scalar in the symmetric updating formula. +*> \endverbatim +*> +*> \param[out] DLAM +*> \verbatim +*> DLAM is DOUBLE PRECISION +*> The computed lambda_I, the I-th updated eigenvalue. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> > 0: if INFO = 1, the updating process failed. +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> Logical variable ORGATI (origin-at-i?) is used for distinguishing +*> whether D(i) or D(i+1) is treated as the origin. +*> +*> ORGATI = .true. origin at i +*> ORGATI = .false. origin at i+1 +*> +*> Logical variable SWTCH3 (switch-for-3-poles?) is for noting +*> if we are working with THREE poles! +*> +*> MAXIT is the maximum number of iterations allowed for each +*> eigenvalue. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Ren-Cang Li, Computer Science Division, University of California +*> at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER I, INFO, N + DOUBLE PRECISION DLAM, RHO +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), DELTA( * ), Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 30 ) + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0, + $ TEN = 10.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL ORGATI, SWTCH, SWTCH3 + INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER + DOUBLE PRECISION A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW, + $ EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI, + $ RHOINV, TAU, TEMP, TEMP1, W +* .. +* .. Local Arrays .. + DOUBLE PRECISION ZZ( 3 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLAED5, DLAED6 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Since this routine is called in an inner loop, we do no argument +* checking. +* +* Quick return for N=1 and 2. +* + INFO = 0 + IF( N.EQ.1 ) THEN +* +* Presumably, I=1 upon entry +* + DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 ) + DELTA( 1 ) = ONE + RETURN + END IF + IF( N.EQ.2 ) THEN + CALL DLAED5( I, D, Z, DELTA, RHO, DLAM ) + RETURN + END IF +* +* Compute machine epsilon +* + EPS = DLAMCH( 'Epsilon' ) + RHOINV = ONE / RHO +* +* The case I = N +* + IF( I.EQ.N ) THEN +* +* Initialize some basic variables +* + II = N - 1 + NITER = 1 +* +* Calculate initial guess +* + MIDPT = RHO / TWO +* +* If ||Z||_2 is not one, then TEMP should be set to +* RHO * ||Z||_2^2 / TWO +* + DO 10 J = 1, N + DELTA( J ) = ( D( J )-D( I ) ) - MIDPT + 10 CONTINUE +* + PSI = ZERO + DO 20 J = 1, N - 2 + PSI = PSI + Z( J )*Z( J ) / DELTA( J ) + 20 CONTINUE +* + C = RHOINV + PSI + W = C + Z( II )*Z( II ) / DELTA( II ) + + $ Z( N )*Z( N ) / DELTA( N ) +* + IF( W.LE.ZERO ) THEN + TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) + + $ Z( N )*Z( N ) / RHO + IF( C.LE.TEMP ) THEN + TAU = RHO + ELSE + DEL = D( N ) - D( N-1 ) + A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) + B = Z( N )*Z( N )*DEL + IF( A.LT.ZERO ) THEN + TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) + ELSE + TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) + END IF + END IF +* +* It can be proved that +* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO +* + DLTLB = MIDPT + DLTUB = RHO + ELSE + DEL = D( N ) - D( N-1 ) + A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) + B = Z( N )*Z( N )*DEL + IF( A.LT.ZERO ) THEN + TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) + ELSE + TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) + END IF +* +* It can be proved that +* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2 +* + DLTLB = ZERO + DLTUB = MIDPT + END IF +* + DO 30 J = 1, N + DELTA( J ) = ( D( J )-D( I ) ) - TAU + 30 CONTINUE +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 40 J = 1, II + TEMP = Z( J ) / DELTA( J ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 40 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + TEMP = Z( N ) / DELTA( N ) + PHI = Z( N )*TEMP + DPHI = TEMP*TEMP + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + + $ ABS( TAU )*( DPSI+DPHI ) +* + W = RHOINV + PHI + PSI +* +* Test for convergence +* + IF( ABS( W ).LE.EPS*ERRETM ) THEN + DLAM = D( I ) + TAU + GO TO 250 + END IF +* + IF( W.LE.ZERO ) THEN + DLTLB = MAX( DLTLB, TAU ) + ELSE + DLTUB = MIN( DLTUB, TAU ) + END IF +* +* Calculate the new step +* + NITER = NITER + 1 + C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI + A = ( DELTA( N-1 )+DELTA( N ) )*W - + $ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI ) + B = DELTA( N-1 )*DELTA( N )*W + IF( C.LT.ZERO ) + $ C = ABS( C ) + IF( C.EQ.ZERO ) THEN +* ETA = B/A +* ETA = RHO - TAU + ETA = DLTUB - TAU + ELSE IF( A.GE.ZERO ) THEN + ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF +* +* Note, eta should be positive if w is negative, and +* eta should be negative otherwise. However, +* if for some reason caused by roundoff, eta*w > 0, +* we simply use one Newton step instead. This way +* will guarantee eta*w < 0. +* + IF( W*ETA.GT.ZERO ) + $ ETA = -W / ( DPSI+DPHI ) + TEMP = TAU + ETA + IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN + IF( W.LT.ZERO ) THEN + ETA = ( DLTUB-TAU ) / TWO + ELSE + ETA = ( DLTLB-TAU ) / TWO + END IF + END IF + DO 50 J = 1, N + DELTA( J ) = DELTA( J ) - ETA + 50 CONTINUE +* + TAU = TAU + ETA +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 60 J = 1, II + TEMP = Z( J ) / DELTA( J ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 60 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + TEMP = Z( N ) / DELTA( N ) + PHI = Z( N )*TEMP + DPHI = TEMP*TEMP + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + + $ ABS( TAU )*( DPSI+DPHI ) +* + W = RHOINV + PHI + PSI +* +* Main loop to update the values of the array DELTA +* + ITER = NITER + 1 +* + DO 90 NITER = ITER, MAXIT +* +* Test for convergence +* + IF( ABS( W ).LE.EPS*ERRETM ) THEN + DLAM = D( I ) + TAU + GO TO 250 + END IF +* + IF( W.LE.ZERO ) THEN + DLTLB = MAX( DLTLB, TAU ) + ELSE + DLTUB = MIN( DLTUB, TAU ) + END IF +* +* Calculate the new step +* + C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI + A = ( DELTA( N-1 )+DELTA( N ) )*W - + $ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI ) + B = DELTA( N-1 )*DELTA( N )*W + IF( A.GE.ZERO ) THEN + ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF +* +* Note, eta should be positive if w is negative, and +* eta should be negative otherwise. However, +* if for some reason caused by roundoff, eta*w > 0, +* we simply use one Newton step instead. This way +* will guarantee eta*w < 0. +* + IF( W*ETA.GT.ZERO ) + $ ETA = -W / ( DPSI+DPHI ) + TEMP = TAU + ETA + IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN + IF( W.LT.ZERO ) THEN + ETA = ( DLTUB-TAU ) / TWO + ELSE + ETA = ( DLTLB-TAU ) / TWO + END IF + END IF + DO 70 J = 1, N + DELTA( J ) = DELTA( J ) - ETA + 70 CONTINUE +* + TAU = TAU + ETA +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 80 J = 1, II + TEMP = Z( J ) / DELTA( J ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 80 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + TEMP = Z( N ) / DELTA( N ) + PHI = Z( N )*TEMP + DPHI = TEMP*TEMP + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + + $ ABS( TAU )*( DPSI+DPHI ) +* + W = RHOINV + PHI + PSI + 90 CONTINUE +* +* Return with INFO = 1, NITER = MAXIT and not converged +* + INFO = 1 + DLAM = D( I ) + TAU + GO TO 250 +* +* End for the case I = N +* + ELSE +* +* The case for I < N +* + NITER = 1 + IP1 = I + 1 +* +* Calculate initial guess +* + DEL = D( IP1 ) - D( I ) + MIDPT = DEL / TWO + DO 100 J = 1, N + DELTA( J ) = ( D( J )-D( I ) ) - MIDPT + 100 CONTINUE +* + PSI = ZERO + DO 110 J = 1, I - 1 + PSI = PSI + Z( J )*Z( J ) / DELTA( J ) + 110 CONTINUE +* + PHI = ZERO + DO 120 J = N, I + 2, -1 + PHI = PHI + Z( J )*Z( J ) / DELTA( J ) + 120 CONTINUE + C = RHOINV + PSI + PHI + W = C + Z( I )*Z( I ) / DELTA( I ) + + $ Z( IP1 )*Z( IP1 ) / DELTA( IP1 ) +* + IF( W.GT.ZERO ) THEN +* +* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2 +* +* We choose d(i) as origin. +* + ORGATI = .TRUE. + A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 ) + B = Z( I )*Z( I )*DEL + IF( A.GT.ZERO ) THEN + TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + ELSE + TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + END IF + DLTLB = ZERO + DLTUB = MIDPT + ELSE +* +* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1) +* +* We choose d(i+1) as origin. +* + ORGATI = .FALSE. + A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 ) + B = Z( IP1 )*Z( IP1 )*DEL + IF( A.LT.ZERO ) THEN + TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) ) + ELSE + TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C ) + END IF + DLTLB = -MIDPT + DLTUB = ZERO + END IF +* + IF( ORGATI ) THEN + DO 130 J = 1, N + DELTA( J ) = ( D( J )-D( I ) ) - TAU + 130 CONTINUE + ELSE + DO 140 J = 1, N + DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU + 140 CONTINUE + END IF + IF( ORGATI ) THEN + II = I + ELSE + II = I + 1 + END IF + IIM1 = II - 1 + IIP1 = II + 1 +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 150 J = 1, IIM1 + TEMP = Z( J ) / DELTA( J ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 150 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + DPHI = ZERO + PHI = ZERO + DO 160 J = N, IIP1, -1 + TEMP = Z( J ) / DELTA( J ) + PHI = PHI + Z( J )*TEMP + DPHI = DPHI + TEMP*TEMP + ERRETM = ERRETM + PHI + 160 CONTINUE +* + W = RHOINV + PHI + PSI +* +* W is the value of the secular function with +* its ii-th element removed. +* + SWTCH3 = .FALSE. + IF( ORGATI ) THEN + IF( W.LT.ZERO ) + $ SWTCH3 = .TRUE. + ELSE + IF( W.GT.ZERO ) + $ SWTCH3 = .TRUE. + END IF + IF( II.EQ.1 .OR. II.EQ.N ) + $ SWTCH3 = .FALSE. +* + TEMP = Z( II ) / DELTA( II ) + DW = DPSI + DPHI + TEMP*TEMP + TEMP = Z( II )*TEMP + W = W + TEMP + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + + $ THREE*ABS( TEMP ) + ABS( TAU )*DW +* +* Test for convergence +* + IF( ABS( W ).LE.EPS*ERRETM ) THEN + IF( ORGATI ) THEN + DLAM = D( I ) + TAU + ELSE + DLAM = D( IP1 ) + TAU + END IF + GO TO 250 + END IF +* + IF( W.LE.ZERO ) THEN + DLTLB = MAX( DLTLB, TAU ) + ELSE + DLTUB = MIN( DLTUB, TAU ) + END IF +* +* Calculate the new step +* + NITER = NITER + 1 + IF( .NOT.SWTCH3 ) THEN + IF( ORGATI ) THEN + C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )* + $ ( Z( I ) / DELTA( I ) )**2 + ELSE + C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )* + $ ( Z( IP1 ) / DELTA( IP1 ) )**2 + END IF + A = ( DELTA( I )+DELTA( IP1 ) )*W - + $ DELTA( I )*DELTA( IP1 )*DW + B = DELTA( I )*DELTA( IP1 )*W + IF( C.EQ.ZERO ) THEN + IF( A.EQ.ZERO ) THEN + IF( ORGATI ) THEN + A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )* + $ ( DPSI+DPHI ) + ELSE + A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )* + $ ( DPSI+DPHI ) + END IF + END IF + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + ELSE +* +* Interpolation using THREE most relevant poles +* + TEMP = RHOINV + PSI + PHI + IF( ORGATI ) THEN + TEMP1 = Z( IIM1 ) / DELTA( IIM1 ) + TEMP1 = TEMP1*TEMP1 + C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) - + $ ( D( IIM1 )-D( IIP1 ) )*TEMP1 + ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) + ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )* + $ ( ( DPSI-TEMP1 )+DPHI ) + ELSE + TEMP1 = Z( IIP1 ) / DELTA( IIP1 ) + TEMP1 = TEMP1*TEMP1 + C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) - + $ ( D( IIP1 )-D( IIM1 ) )*TEMP1 + ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )* + $ ( DPSI+( DPHI-TEMP1 ) ) + ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) + END IF + ZZ( 2 ) = Z( II )*Z( II ) + CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA, + $ INFO ) + IF( INFO.NE.0 ) + $ GO TO 250 + END IF +* +* Note, eta should be positive if w is negative, and +* eta should be negative otherwise. However, +* if for some reason caused by roundoff, eta*w > 0, +* we simply use one Newton step instead. This way +* will guarantee eta*w < 0. +* + IF( W*ETA.GE.ZERO ) + $ ETA = -W / DW + TEMP = TAU + ETA + IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN + IF( W.LT.ZERO ) THEN + ETA = ( DLTUB-TAU ) / TWO + ELSE + ETA = ( DLTLB-TAU ) / TWO + END IF + END IF +* + PREW = W +* + DO 180 J = 1, N + DELTA( J ) = DELTA( J ) - ETA + 180 CONTINUE +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 190 J = 1, IIM1 + TEMP = Z( J ) / DELTA( J ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 190 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + DPHI = ZERO + PHI = ZERO + DO 200 J = N, IIP1, -1 + TEMP = Z( J ) / DELTA( J ) + PHI = PHI + Z( J )*TEMP + DPHI = DPHI + TEMP*TEMP + ERRETM = ERRETM + PHI + 200 CONTINUE +* + TEMP = Z( II ) / DELTA( II ) + DW = DPSI + DPHI + TEMP*TEMP + TEMP = Z( II )*TEMP + W = RHOINV + PHI + PSI + TEMP + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + + $ THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW +* + SWTCH = .FALSE. + IF( ORGATI ) THEN + IF( -W.GT.ABS( PREW ) / TEN ) + $ SWTCH = .TRUE. + ELSE + IF( W.GT.ABS( PREW ) / TEN ) + $ SWTCH = .TRUE. + END IF +* + TAU = TAU + ETA +* +* Main loop to update the values of the array DELTA +* + ITER = NITER + 1 +* + DO 240 NITER = ITER, MAXIT +* +* Test for convergence +* + IF( ABS( W ).LE.EPS*ERRETM ) THEN + IF( ORGATI ) THEN + DLAM = D( I ) + TAU + ELSE + DLAM = D( IP1 ) + TAU + END IF + GO TO 250 + END IF +* + IF( W.LE.ZERO ) THEN + DLTLB = MAX( DLTLB, TAU ) + ELSE + DLTUB = MIN( DLTUB, TAU ) + END IF +* +* Calculate the new step +* + IF( .NOT.SWTCH3 ) THEN + IF( .NOT.SWTCH ) THEN + IF( ORGATI ) THEN + C = W - DELTA( IP1 )*DW - + $ ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2 + ELSE + C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )* + $ ( Z( IP1 ) / DELTA( IP1 ) )**2 + END IF + ELSE + TEMP = Z( II ) / DELTA( II ) + IF( ORGATI ) THEN + DPSI = DPSI + TEMP*TEMP + ELSE + DPHI = DPHI + TEMP*TEMP + END IF + C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI + END IF + A = ( DELTA( I )+DELTA( IP1 ) )*W - + $ DELTA( I )*DELTA( IP1 )*DW + B = DELTA( I )*DELTA( IP1 )*W + IF( C.EQ.ZERO ) THEN + IF( A.EQ.ZERO ) THEN + IF( .NOT.SWTCH ) THEN + IF( ORGATI ) THEN + A = Z( I )*Z( I ) + DELTA( IP1 )* + $ DELTA( IP1 )*( DPSI+DPHI ) + ELSE + A = Z( IP1 )*Z( IP1 ) + + $ DELTA( I )*DELTA( I )*( DPSI+DPHI ) + END IF + ELSE + A = DELTA( I )*DELTA( I )*DPSI + + $ DELTA( IP1 )*DELTA( IP1 )*DPHI + END IF + END IF + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + ELSE +* +* Interpolation using THREE most relevant poles +* + TEMP = RHOINV + PSI + PHI + IF( SWTCH ) THEN + C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI + ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI + ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI + ELSE + IF( ORGATI ) THEN + TEMP1 = Z( IIM1 ) / DELTA( IIM1 ) + TEMP1 = TEMP1*TEMP1 + C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) - + $ ( D( IIM1 )-D( IIP1 ) )*TEMP1 + ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) + ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )* + $ ( ( DPSI-TEMP1 )+DPHI ) + ELSE + TEMP1 = Z( IIP1 ) / DELTA( IIP1 ) + TEMP1 = TEMP1*TEMP1 + C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) - + $ ( D( IIP1 )-D( IIM1 ) )*TEMP1 + ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )* + $ ( DPSI+( DPHI-TEMP1 ) ) + ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) + END IF + END IF + CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA, + $ INFO ) + IF( INFO.NE.0 ) + $ GO TO 250 + END IF +* +* Note, eta should be positive if w is negative, and +* eta should be negative otherwise. However, +* if for some reason caused by roundoff, eta*w > 0, +* we simply use one Newton step instead. This way +* will guarantee eta*w < 0. +* + IF( W*ETA.GE.ZERO ) + $ ETA = -W / DW + TEMP = TAU + ETA + IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN + IF( W.LT.ZERO ) THEN + ETA = ( DLTUB-TAU ) / TWO + ELSE + ETA = ( DLTLB-TAU ) / TWO + END IF + END IF +* + DO 210 J = 1, N + DELTA( J ) = DELTA( J ) - ETA + 210 CONTINUE +* + TAU = TAU + ETA + PREW = W +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 220 J = 1, IIM1 + TEMP = Z( J ) / DELTA( J ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 220 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + DPHI = ZERO + PHI = ZERO + DO 230 J = N, IIP1, -1 + TEMP = Z( J ) / DELTA( J ) + PHI = PHI + Z( J )*TEMP + DPHI = DPHI + TEMP*TEMP + ERRETM = ERRETM + PHI + 230 CONTINUE +* + TEMP = Z( II ) / DELTA( II ) + DW = DPSI + DPHI + TEMP*TEMP + TEMP = Z( II )*TEMP + W = RHOINV + PHI + PSI + TEMP + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + + $ THREE*ABS( TEMP ) + ABS( TAU )*DW + IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) + $ SWTCH = .NOT.SWTCH +* + 240 CONTINUE +* +* Return with INFO = 1, NITER = MAXIT and not converged +* + INFO = 1 + IF( ORGATI ) THEN + DLAM = D( I ) + TAU + ELSE + DLAM = D( IP1 ) + TAU + END IF +* + END IF +* + 250 CONTINUE +* + RETURN +* +* End of DLAED4 +* + END diff --git a/math/lapack/src/main/fortran/dlaed5.f b/math/lapack/src/main/fortran/dlaed5.f new file mode 100644 index 0000000000..3ea9e401cf --- /dev/null +++ b/math/lapack/src/main/fortran/dlaed5.f @@ -0,0 +1,189 @@ +*> \brief \b DLAED5 used by sstedc. Solves the 2-by-2 secular equation. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAED5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) +* +* .. Scalar Arguments .. +* INTEGER I +* DOUBLE PRECISION DLAM, RHO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This subroutine computes the I-th eigenvalue of a symmetric rank-one +*> modification of a 2-by-2 diagonal matrix +*> +*> diag( D ) + RHO * Z * transpose(Z) . +*> +*> The diagonal elements in the array D are assumed to satisfy +*> +*> D(i) < D(j) for i < j . +*> +*> We also assume RHO > 0 and that the Euclidean norm of the vector +*> Z is one. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] I +*> \verbatim +*> I is INTEGER +*> The index of the eigenvalue to be computed. I = 1 or I = 2. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (2) +*> The original eigenvalues. We assume D(1) < D(2). +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (2) +*> The components of the updating vector. +*> \endverbatim +*> +*> \param[out] DELTA +*> \verbatim +*> DELTA is DOUBLE PRECISION array, dimension (2) +*> The vector DELTA contains the information necessary +*> to construct the eigenvectors. +*> \endverbatim +*> +*> \param[in] RHO +*> \verbatim +*> RHO is DOUBLE PRECISION +*> The scalar in the symmetric updating formula. +*> \endverbatim +*> +*> \param[out] DLAM +*> \verbatim +*> DLAM is DOUBLE PRECISION +*> The computed lambda_I, the I-th updated eigenvalue. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Ren-Cang Li, Computer Science Division, University of California +*> at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER I + DOUBLE PRECISION DLAM, RHO +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, FOUR + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ FOUR = 4.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION B, C, DEL, TAU, TEMP, W +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* + DEL = D( 2 ) - D( 1 ) + IF( I.EQ.1 ) THEN + W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL + IF( W.GT.ZERO ) THEN + B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) + C = RHO*Z( 1 )*Z( 1 )*DEL +* +* B > ZERO, always +* + TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) ) + DLAM = D( 1 ) + TAU + DELTA( 1 ) = -Z( 1 ) / TAU + DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) + ELSE + B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) + C = RHO*Z( 2 )*Z( 2 )*DEL + IF( B.GT.ZERO ) THEN + TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) ) + ELSE + TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO + END IF + DLAM = D( 2 ) + TAU + DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) + DELTA( 2 ) = -Z( 2 ) / TAU + END IF + TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) + DELTA( 1 ) = DELTA( 1 ) / TEMP + DELTA( 2 ) = DELTA( 2 ) / TEMP + ELSE +* +* Now I=2 +* + B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) + C = RHO*Z( 2 )*Z( 2 )*DEL + IF( B.GT.ZERO ) THEN + TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO + ELSE + TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) ) + END IF + DLAM = D( 2 ) + TAU + DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) + DELTA( 2 ) = -Z( 2 ) / TAU + TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) + DELTA( 1 ) = DELTA( 1 ) / TEMP + DELTA( 2 ) = DELTA( 2 ) / TEMP + END IF + RETURN +* +* End OF DLAED5 +* + END diff --git a/math/lapack/src/main/fortran/dlaed6.f b/math/lapack/src/main/fortran/dlaed6.f new file mode 100644 index 0000000000..daa8db39e4 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaed6.f @@ -0,0 +1,410 @@ +*> \brief \b DLAED6 used by sstedc. Computes one Newton step in solution of the secular equation. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAED6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) +* +* .. Scalar Arguments .. +* LOGICAL ORGATI +* INTEGER INFO, KNITER +* DOUBLE PRECISION FINIT, RHO, TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( 3 ), Z( 3 ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAED6 computes the positive or negative root (closest to the origin) +*> of +*> z(1) z(2) z(3) +*> f(x) = rho + --------- + ---------- + --------- +*> d(1)-x d(2)-x d(3)-x +*> +*> It is assumed that +*> +*> if ORGATI = .true. the root is between d(2) and d(3); +*> otherwise it is between d(1) and d(2) +*> +*> This routine will be called by DLAED4 when necessary. In most cases, +*> the root sought is the smallest in magnitude, though it might not be +*> in some extremely rare situations. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] KNITER +*> \verbatim +*> KNITER is INTEGER +*> Refer to DLAED4 for its significance. +*> \endverbatim +*> +*> \param[in] ORGATI +*> \verbatim +*> ORGATI is LOGICAL +*> If ORGATI is true, the needed root is between d(2) and +*> d(3); otherwise it is between d(1) and d(2). See +*> DLAED4 for further details. +*> \endverbatim +*> +*> \param[in] RHO +*> \verbatim +*> RHO is DOUBLE PRECISION +*> Refer to the equation f(x) above. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (3) +*> D satisfies d(1) < d(2) < d(3). +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (3) +*> Each of the elements in z must be positive. +*> \endverbatim +*> +*> \param[in] FINIT +*> \verbatim +*> FINIT is DOUBLE PRECISION +*> The value of f at 0. It is more accurate than the one +*> evaluated inside this routine (if someone wants to do +*> so). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> The root of the equation f(x). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> > 0: if INFO = 1, failure to converge +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 10/02/03: This version has a few statements commented out for thread +*> safety (machine parameters are computed on each entry). SJH. +*> +*> 05/10/06: Modified from a new version of Ren-Cang Li, use +*> Gragg-Thornton-Warner cubic convergent scheme for better stability. +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> Ren-Cang Li, Computer Science Division, University of California +*> at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + LOGICAL ORGATI + INTEGER INFO, KNITER + DOUBLE PRECISION FINIT, RHO, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( 3 ), Z( 3 ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 40 ) + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Local Arrays .. + DOUBLE PRECISION DSCALE( 3 ), ZSCALE( 3 ) +* .. +* .. Local Scalars .. + LOGICAL SCALE + INTEGER I, ITER, NITER + DOUBLE PRECISION A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F, + $ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1, + $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4, + $ LBD, UBD +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 +* + IF( ORGATI ) THEN + LBD = D(2) + UBD = D(3) + ELSE + LBD = D(1) + UBD = D(2) + END IF + IF( FINIT .LT. ZERO )THEN + LBD = ZERO + ELSE + UBD = ZERO + END IF +* + NITER = 1 + TAU = ZERO + IF( KNITER.EQ.2 ) THEN + IF( ORGATI ) THEN + TEMP = ( D( 3 )-D( 2 ) ) / TWO + C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP ) + A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 ) + B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 ) + ELSE + TEMP = ( D( 1 )-D( 2 ) ) / TWO + C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP ) + A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 ) + B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 ) + END IF + TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) + A = A / TEMP + B = B / TEMP + C = C / TEMP + IF( C.EQ.ZERO ) THEN + TAU = B / A + ELSE IF( A.LE.ZERO ) THEN + TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + IF( TAU .LT. LBD .OR. TAU .GT. UBD ) + $ TAU = ( LBD+UBD )/TWO + IF( D(1).EQ.TAU .OR. D(2).EQ.TAU .OR. D(3).EQ.TAU ) THEN + TAU = ZERO + ELSE + TEMP = FINIT + TAU*Z(1)/( D(1)*( D( 1 )-TAU ) ) + + $ TAU*Z(2)/( D(2)*( D( 2 )-TAU ) ) + + $ TAU*Z(3)/( D(3)*( D( 3 )-TAU ) ) + IF( TEMP .LE. ZERO )THEN + LBD = TAU + ELSE + UBD = TAU + END IF + IF( ABS( FINIT ).LE.ABS( TEMP ) ) + $ TAU = ZERO + END IF + END IF +* +* get machine parameters for possible scaling to avoid overflow +* +* modified by Sven: parameters SMALL1, SMINV1, SMALL2, +* SMINV2, EPS are not SAVEd anymore between one call to the +* others but recomputed at each call +* + EPS = DLAMCH( 'Epsilon' ) + BASE = DLAMCH( 'Base' ) + SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin' ) ) / LOG( BASE ) / + $ THREE ) ) + SMINV1 = ONE / SMALL1 + SMALL2 = SMALL1*SMALL1 + SMINV2 = SMINV1*SMINV1 +* +* Determine if scaling of inputs necessary to avoid overflow +* when computing 1/TEMP**3 +* + IF( ORGATI ) THEN + TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) ) + ELSE + TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) ) + END IF + SCALE = .FALSE. + IF( TEMP.LE.SMALL1 ) THEN + SCALE = .TRUE. + IF( TEMP.LE.SMALL2 ) THEN +* +* Scale up by power of radix nearest 1/SAFMIN**(2/3) +* + SCLFAC = SMINV2 + SCLINV = SMALL2 + ELSE +* +* Scale up by power of radix nearest 1/SAFMIN**(1/3) +* + SCLFAC = SMINV1 + SCLINV = SMALL1 + END IF +* +* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) +* + DO 10 I = 1, 3 + DSCALE( I ) = D( I )*SCLFAC + ZSCALE( I ) = Z( I )*SCLFAC + 10 CONTINUE + TAU = TAU*SCLFAC + LBD = LBD*SCLFAC + UBD = UBD*SCLFAC + ELSE +* +* Copy D and Z to DSCALE and ZSCALE +* + DO 20 I = 1, 3 + DSCALE( I ) = D( I ) + ZSCALE( I ) = Z( I ) + 20 CONTINUE + END IF +* + FC = ZERO + DF = ZERO + DDF = ZERO + DO 30 I = 1, 3 + TEMP = ONE / ( DSCALE( I )-TAU ) + TEMP1 = ZSCALE( I )*TEMP + TEMP2 = TEMP1*TEMP + TEMP3 = TEMP2*TEMP + FC = FC + TEMP1 / DSCALE( I ) + DF = DF + TEMP2 + DDF = DDF + TEMP3 + 30 CONTINUE + F = FINIT + TAU*FC +* + IF( ABS( F ).LE.ZERO ) + $ GO TO 60 + IF( F .LE. ZERO )THEN + LBD = TAU + ELSE + UBD = TAU + END IF +* +* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent +* scheme +* +* It is not hard to see that +* +* 1) Iterations will go up monotonically +* if FINIT < 0; +* +* 2) Iterations will go down monotonically +* if FINIT > 0. +* + ITER = NITER + 1 +* + DO 50 NITER = ITER, MAXIT +* + IF( ORGATI ) THEN + TEMP1 = DSCALE( 2 ) - TAU + TEMP2 = DSCALE( 3 ) - TAU + ELSE + TEMP1 = DSCALE( 1 ) - TAU + TEMP2 = DSCALE( 2 ) - TAU + END IF + A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF + B = TEMP1*TEMP2*F + C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF + TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) + A = A / TEMP + B = B / TEMP + C = C / TEMP + IF( C.EQ.ZERO ) THEN + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + IF( F*ETA.GE.ZERO ) THEN + ETA = -F / DF + END IF +* + TAU = TAU + ETA + IF( TAU .LT. LBD .OR. TAU .GT. UBD ) + $ TAU = ( LBD + UBD )/TWO +* + FC = ZERO + ERRETM = ZERO + DF = ZERO + DDF = ZERO + DO 40 I = 1, 3 + IF ( ( DSCALE( I )-TAU ).NE.ZERO ) THEN + TEMP = ONE / ( DSCALE( I )-TAU ) + TEMP1 = ZSCALE( I )*TEMP + TEMP2 = TEMP1*TEMP + TEMP3 = TEMP2*TEMP + TEMP4 = TEMP1 / DSCALE( I ) + FC = FC + TEMP4 + ERRETM = ERRETM + ABS( TEMP4 ) + DF = DF + TEMP2 + DDF = DDF + TEMP3 + ELSE + GO TO 60 + END IF + 40 CONTINUE + F = FINIT + TAU*FC + ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) + + $ ABS( TAU )*DF + IF( ( ABS( F ).LE.FOUR*EPS*ERRETM ) .OR. + $ ( (UBD-LBD).LE.FOUR*EPS*ABS(TAU) ) ) + $ GO TO 60 + IF( F .LE. ZERO )THEN + LBD = TAU + ELSE + UBD = TAU + END IF + 50 CONTINUE + INFO = 1 + 60 CONTINUE +* +* Undo scaling +* + IF( SCALE ) + $ TAU = TAU*SCLINV + RETURN +* +* End of DLAED6 +* + END diff --git a/math/lapack/src/main/fortran/dlaed7.f b/math/lapack/src/main/fortran/dlaed7.f new file mode 100644 index 0000000000..9c528added --- /dev/null +++ b/math/lapack/src/main/fortran/dlaed7.f @@ -0,0 +1,407 @@ +*> \brief \b DLAED7 used by sstedc. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is dense. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAED7 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, +* LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, +* PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, +* $ QSIZ, TLVLS +* DOUBLE PRECISION RHO +* .. +* .. Array Arguments .. +* INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), +* $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) +* DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ), +* $ QSTORE( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAED7 computes the updated eigensystem of a diagonal +*> matrix after modification by a rank-one symmetric matrix. This +*> routine is used only for the eigenproblem which requires all +*> eigenvalues and optionally eigenvectors of a dense symmetric matrix +*> that has been reduced to tridiagonal form. DLAED1 handles +*> the case in which all eigenvalues and eigenvectors of a symmetric +*> tridiagonal matrix are desired. +*> +*> T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out) +*> +*> where Z = Q**Tu, u is a vector of length N with ones in the +*> CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. +*> +*> The eigenvectors of the original matrix are stored in Q, and the +*> eigenvalues are in D. The algorithm consists of three stages: +*> +*> The first stage consists of deflating the size of the problem +*> when there are multiple eigenvalues or if there is a zero in +*> the Z vector. For each such occurrence the dimension of the +*> secular equation problem is reduced by one. This stage is +*> performed by the routine DLAED8. +*> +*> The second stage consists of calculating the updated +*> eigenvalues. This is done by finding the roots of the secular +*> equation via the routine DLAED4 (as called by DLAED9). +*> This routine also calculates the eigenvectors of the current +*> problem. +*> +*> The final stage consists of computing the updated eigenvectors +*> directly using the updated eigenvalues. The eigenvectors for +*> the current problem are multiplied with the eigenvectors from +*> the overall problem. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ICOMPQ +*> \verbatim +*> ICOMPQ is INTEGER +*> = 0: Compute eigenvalues only. +*> = 1: Compute eigenvectors of original dense symmetric matrix +*> also. On entry, Q contains the orthogonal matrix used +*> to reduce the original matrix to tridiagonal form. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The dimension of the symmetric tridiagonal matrix. N >= 0. +*> \endverbatim +*> +*> \param[in] QSIZ +*> \verbatim +*> QSIZ is INTEGER +*> The dimension of the orthogonal matrix used to reduce +*> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. +*> \endverbatim +*> +*> \param[in] TLVLS +*> \verbatim +*> TLVLS is INTEGER +*> The total number of merging levels in the overall divide and +*> conquer tree. +*> \endverbatim +*> +*> \param[in] CURLVL +*> \verbatim +*> CURLVL is INTEGER +*> The current level in the overall merge routine, +*> 0 <= CURLVL <= TLVLS. +*> \endverbatim +*> +*> \param[in] CURPBM +*> \verbatim +*> CURPBM is INTEGER +*> The current problem in the current level in the overall +*> merge routine (counting from upper left to lower right). +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the eigenvalues of the rank-1-perturbed matrix. +*> On exit, the eigenvalues of the repaired matrix. +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ, N) +*> On entry, the eigenvectors of the rank-1-perturbed matrix. +*> On exit, the eigenvectors of the repaired tridiagonal matrix. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= max(1,N). +*> \endverbatim +*> +*> \param[out] INDXQ +*> \verbatim +*> INDXQ is INTEGER array, dimension (N) +*> The permutation which will reintegrate the subproblem just +*> solved back into sorted order, i.e., D( INDXQ( I = 1, N ) ) +*> will be in ascending order. +*> \endverbatim +*> +*> \param[in] RHO +*> \verbatim +*> RHO is DOUBLE PRECISION +*> The subdiagonal element used to create the rank-1 +*> modification. +*> \endverbatim +*> +*> \param[in] CUTPNT +*> \verbatim +*> CUTPNT is INTEGER +*> Contains the location of the last eigenvalue in the leading +*> sub-matrix. min(1,N) <= CUTPNT <= N. +*> \endverbatim +*> +*> \param[in,out] QSTORE +*> \verbatim +*> QSTORE is DOUBLE PRECISION array, dimension (N**2+1) +*> Stores eigenvectors of submatrices encountered during +*> divide and conquer, packed together. QPTR points to +*> beginning of the submatrices. +*> \endverbatim +*> +*> \param[in,out] QPTR +*> \verbatim +*> QPTR is INTEGER array, dimension (N+2) +*> List of indices pointing to beginning of submatrices stored +*> in QSTORE. The submatrices are numbered starting at the +*> bottom left of the divide and conquer tree, from left to +*> right and bottom to top. +*> \endverbatim +*> +*> \param[in] PRMPTR +*> \verbatim +*> PRMPTR is INTEGER array, dimension (N lg N) +*> Contains a list of pointers which indicate where in PERM a +*> level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) +*> indicates the size of the permutation and also the size of +*> the full, non-deflated problem. +*> \endverbatim +*> +*> \param[in] PERM +*> \verbatim +*> PERM is INTEGER array, dimension (N lg N) +*> Contains the permutations (from deflation and sorting) to be +*> applied to each eigenblock. +*> \endverbatim +*> +*> \param[in] GIVPTR +*> \verbatim +*> GIVPTR is INTEGER array, dimension (N lg N) +*> Contains a list of pointers which indicate where in GIVCOL a +*> level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) +*> indicates the number of Givens rotations. +*> \endverbatim +*> +*> \param[in] GIVCOL +*> \verbatim +*> GIVCOL is INTEGER array, dimension (2, N lg N) +*> Each pair of numbers indicates a pair of columns to take place +*> in a Givens rotation. +*> \endverbatim +*> +*> \param[in] GIVNUM +*> \verbatim +*> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N) +*> Each number indicates the S value to be used in the +*> corresponding Givens rotation. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N+2*QSIZ*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (4*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = 1, an eigenvalue did not converge +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup auxOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Jeff Rutter, Computer Science Division, University of California +*> at Berkeley, USA +* +* ===================================================================== + SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, + $ LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, + $ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, + $ QSIZ, TLVLS + DOUBLE PRECISION RHO +* .. +* .. Array Arguments .. + INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), + $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) + DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ), + $ QSTORE( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP, + $ IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLAED8, DLAED9, DLAEDA, DLAMRG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN + INFO = -3 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN + INFO = -12 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAED7', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* The following values are for bookkeeping purposes only. They are +* integer pointers which indicate the portion of the workspace +* used by a particular array in DLAED8 and DLAED9. +* + IF( ICOMPQ.EQ.1 ) THEN + LDQ2 = QSIZ + ELSE + LDQ2 = N + END IF +* + IZ = 1 + IDLMDA = IZ + N + IW = IDLMDA + N + IQ2 = IW + N + IS = IQ2 + N*LDQ2 +* + INDX = 1 + INDXC = INDX + N + COLTYP = INDXC + N + INDXP = COLTYP + N +* +* Form the z-vector which consists of the last row of Q_1 and the +* first row of Q_2. +* + PTR = 1 + 2**TLVLS + DO 10 I = 1, CURLVL - 1 + PTR = PTR + 2**( TLVLS-I ) + 10 CONTINUE + CURR = PTR + CURPBM + CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, + $ GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ), + $ WORK( IZ+N ), INFO ) +* +* When solving the final problem, we no longer need the stored data, +* so we will overwrite the data from this level onto the previously +* used storage space. +* + IF( CURLVL.EQ.TLVLS ) THEN + QPTR( CURR ) = 1 + PRMPTR( CURR ) = 1 + GIVPTR( CURR ) = 1 + END IF +* +* Sort and Deflate eigenvalues. +* + CALL DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT, + $ WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2, + $ WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ), + $ GIVCOL( 1, GIVPTR( CURR ) ), + $ GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ), + $ IWORK( INDX ), INFO ) + PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N + GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR ) +* +* Solve Secular Equation. +* + IF( K.NE.0 ) THEN + CALL DLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ), + $ WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO ) + IF( INFO.NE.0 ) + $ GO TO 30 + IF( ICOMPQ.EQ.1 ) THEN + CALL DGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2, + $ QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ ) + END IF + QPTR( CURR+1 ) = QPTR( CURR ) + K**2 +* +* Prepare the INDXQ sorting permutation. +* + N1 = K + N2 = N - K + CALL DLAMRG( N1, N2, D, 1, -1, INDXQ ) + ELSE + QPTR( CURR+1 ) = QPTR( CURR ) + DO 20 I = 1, N + INDXQ( I ) = I + 20 CONTINUE + END IF +* + 30 CONTINUE + RETURN +* +* End of DLAED7 +* + END diff --git a/math/lapack/src/main/fortran/dlaed8.f b/math/lapack/src/main/fortran/dlaed8.f new file mode 100644 index 0000000000..c053347b10 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaed8.f @@ -0,0 +1,524 @@ +*> \brief \b DLAED8 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original matrix is dense. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAED8 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, +* CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, +* GIVCOL, GIVNUM, INDXP, INDX, INFO ) +* +* .. Scalar Arguments .. +* INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, +* $ QSIZ +* DOUBLE PRECISION RHO +* .. +* .. Array Arguments .. +* INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), +* $ INDXQ( * ), PERM( * ) +* DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), +* $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAED8 merges the two sets of eigenvalues together into a single +*> sorted set. Then it tries to deflate the size of the problem. +*> There are two ways in which deflation can occur: when two or more +*> eigenvalues are close together or if there is a tiny element in the +*> Z vector. For each such occurrence the order of the related secular +*> equation problem is reduced by one. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ICOMPQ +*> \verbatim +*> ICOMPQ is INTEGER +*> = 0: Compute eigenvalues only. +*> = 1: Compute eigenvectors of original dense symmetric matrix +*> also. On entry, Q contains the orthogonal matrix used +*> to reduce the original matrix to tridiagonal form. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> The number of non-deflated eigenvalues, and the order of the +*> related secular equation. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The dimension of the symmetric tridiagonal matrix. N >= 0. +*> \endverbatim +*> +*> \param[in] QSIZ +*> \verbatim +*> QSIZ is INTEGER +*> The dimension of the orthogonal matrix used to reduce +*> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the eigenvalues of the two submatrices to be +*> combined. On exit, the trailing (N-K) updated eigenvalues +*> (those which were deflated) sorted into increasing order. +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ,N) +*> If ICOMPQ = 0, Q is not referenced. Otherwise, +*> on entry, Q contains the eigenvectors of the partially solved +*> system which has been previously updated in matrix +*> multiplies with other partially solved eigensystems. +*> On exit, Q contains the trailing (N-K) updated eigenvectors +*> (those which were deflated) in its last N-K columns. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= max(1,N). +*> \endverbatim +*> +*> \param[in] INDXQ +*> \verbatim +*> INDXQ is INTEGER array, dimension (N) +*> The permutation which separately sorts the two sub-problems +*> in D into ascending order. Note that elements in the second +*> half of this permutation must first have CUTPNT added to +*> their values in order to be accurate. +*> \endverbatim +*> +*> \param[in,out] RHO +*> \verbatim +*> RHO is DOUBLE PRECISION +*> On entry, the off-diagonal element associated with the rank-1 +*> cut which originally split the two submatrices which are now +*> being recombined. +*> On exit, RHO has been modified to the value required by +*> DLAED3. +*> \endverbatim +*> +*> \param[in] CUTPNT +*> \verbatim +*> CUTPNT is INTEGER +*> The location of the last eigenvalue in the leading +*> sub-matrix. min(1,N) <= CUTPNT <= N. +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (N) +*> On entry, Z contains the updating vector (the last row of +*> the first sub-eigenvector matrix and the first row of the +*> second sub-eigenvector matrix). +*> On exit, the contents of Z are destroyed by the updating +*> process. +*> \endverbatim +*> +*> \param[out] DLAMDA +*> \verbatim +*> DLAMDA is DOUBLE PRECISION array, dimension (N) +*> A copy of the first K eigenvalues which will be used by +*> DLAED3 to form the secular equation. +*> \endverbatim +*> +*> \param[out] Q2 +*> \verbatim +*> Q2 is DOUBLE PRECISION array, dimension (LDQ2,N) +*> If ICOMPQ = 0, Q2 is not referenced. Otherwise, +*> a copy of the first K eigenvectors which will be used by +*> DLAED7 in a matrix multiply (DGEMM) to update the new +*> eigenvectors. +*> \endverbatim +*> +*> \param[in] LDQ2 +*> \verbatim +*> LDQ2 is INTEGER +*> The leading dimension of the array Q2. LDQ2 >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first k values of the final deflation-altered z-vector and +*> will be passed to DLAED3. +*> \endverbatim +*> +*> \param[out] PERM +*> \verbatim +*> PERM is INTEGER array, dimension (N) +*> The permutations (from deflation and sorting) to be applied +*> to each eigenblock. +*> \endverbatim +*> +*> \param[out] GIVPTR +*> \verbatim +*> GIVPTR is INTEGER +*> The number of Givens rotations which took place in this +*> subproblem. +*> \endverbatim +*> +*> \param[out] GIVCOL +*> \verbatim +*> GIVCOL is INTEGER array, dimension (2, N) +*> Each pair of numbers indicates a pair of columns to take place +*> in a Givens rotation. +*> \endverbatim +*> +*> \param[out] GIVNUM +*> \verbatim +*> GIVNUM is DOUBLE PRECISION array, dimension (2, N) +*> Each number indicates the S value to be used in the +*> corresponding Givens rotation. +*> \endverbatim +*> +*> \param[out] INDXP +*> \verbatim +*> INDXP is INTEGER array, dimension (N) +*> The permutation used to place deflated values of D at the end +*> of the array. INDXP(1:K) points to the nondeflated D-values +*> and INDXP(K+1:N) points to the deflated eigenvalues. +*> \endverbatim +*> +*> \param[out] INDX +*> \verbatim +*> INDX is INTEGER array, dimension (N) +*> The permutation used to sort the contents of D into ascending +*> order. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Jeff Rutter, Computer Science Division, University of California +*> at Berkeley, USA +* +* ===================================================================== + SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, + $ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, + $ GIVCOL, GIVNUM, INDXP, INDX, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, + $ QSIZ + DOUBLE PRECISION RHO +* .. +* .. Array Arguments .. + INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), + $ INDXQ( * ), PERM( * ) + DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), + $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT + PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0, + $ TWO = 2.0D0, EIGHT = 8.0D0 ) +* .. +* .. Local Scalars .. +* + INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2 + DOUBLE PRECISION C, EPS, S, T, TAU, TOL +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL IDAMAX, DLAMCH, DLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN + INFO = -4 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN + INFO = -10 + ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAED8', -INFO ) + RETURN + END IF +* +* Need to initialize GIVPTR to O here in case of quick exit +* to prevent an unspecified code behavior (usually sigfault) +* when IWORK array on entry to *stedc is not zeroed +* (or at least some IWORK entries which used in *laed7 for GIVPTR). +* + GIVPTR = 0 +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + N1 = CUTPNT + N2 = N - N1 + N1P1 = N1 + 1 +* + IF( RHO.LT.ZERO ) THEN + CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) + END IF +* +* Normalize z so that norm(z) = 1 +* + T = ONE / SQRT( TWO ) + DO 10 J = 1, N + INDX( J ) = J + 10 CONTINUE + CALL DSCAL( N, T, Z, 1 ) + RHO = ABS( TWO*RHO ) +* +* Sort the eigenvalues into increasing order +* + DO 20 I = CUTPNT + 1, N + INDXQ( I ) = INDXQ( I ) + CUTPNT + 20 CONTINUE + DO 30 I = 1, N + DLAMDA( I ) = D( INDXQ( I ) ) + W( I ) = Z( INDXQ( I ) ) + 30 CONTINUE + I = 1 + J = CUTPNT + 1 + CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX ) + DO 40 I = 1, N + D( I ) = DLAMDA( INDX( I ) ) + Z( I ) = W( INDX( I ) ) + 40 CONTINUE +* +* Calculate the allowable deflation tolerence +* + IMAX = IDAMAX( N, Z, 1 ) + JMAX = IDAMAX( N, D, 1 ) + EPS = DLAMCH( 'Epsilon' ) + TOL = EIGHT*EPS*ABS( D( JMAX ) ) +* +* If the rank-1 modifier is small enough, no more needs to be done +* except to reorganize Q so that its columns correspond with the +* elements in D. +* + IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN + K = 0 + IF( ICOMPQ.EQ.0 ) THEN + DO 50 J = 1, N + PERM( J ) = INDXQ( INDX( J ) ) + 50 CONTINUE + ELSE + DO 60 J = 1, N + PERM( J ) = INDXQ( INDX( J ) ) + CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) + 60 CONTINUE + CALL DLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), + $ LDQ ) + END IF + RETURN + END IF +* +* If there are multiple eigenvalues then the problem deflates. Here +* the number of equal eigenvalues are found. As each equal +* eigenvalue is found, an elementary reflector is computed to rotate +* the corresponding eigensubspace so that the corresponding +* components of Z are zero in this new basis. +* + K = 0 + K2 = N + 1 + DO 70 J = 1, N + IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN +* +* Deflate due to small z component. +* + K2 = K2 - 1 + INDXP( K2 ) = J + IF( J.EQ.N ) + $ GO TO 110 + ELSE + JLAM = J + GO TO 80 + END IF + 70 CONTINUE + 80 CONTINUE + J = J + 1 + IF( J.GT.N ) + $ GO TO 100 + IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN +* +* Deflate due to small z component. +* + K2 = K2 - 1 + INDXP( K2 ) = J + ELSE +* +* Check if eigenvalues are close enough to allow deflation. +* + S = Z( JLAM ) + C = Z( J ) +* +* Find sqrt(a**2+b**2) without overflow or +* destructive underflow. +* + TAU = DLAPY2( C, S ) + T = D( J ) - D( JLAM ) + C = C / TAU + S = -S / TAU + IF( ABS( T*C*S ).LE.TOL ) THEN +* +* Deflation is possible. +* + Z( J ) = TAU + Z( JLAM ) = ZERO +* +* Record the appropriate Givens rotation +* + GIVPTR = GIVPTR + 1 + GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) ) + GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) ) + GIVNUM( 1, GIVPTR ) = C + GIVNUM( 2, GIVPTR ) = S + IF( ICOMPQ.EQ.1 ) THEN + CALL DROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1, + $ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S ) + END IF + T = D( JLAM )*C*C + D( J )*S*S + D( J ) = D( JLAM )*S*S + D( J )*C*C + D( JLAM ) = T + K2 = K2 - 1 + I = 1 + 90 CONTINUE + IF( K2+I.LE.N ) THEN + IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN + INDXP( K2+I-1 ) = INDXP( K2+I ) + INDXP( K2+I ) = JLAM + I = I + 1 + GO TO 90 + ELSE + INDXP( K2+I-1 ) = JLAM + END IF + ELSE + INDXP( K2+I-1 ) = JLAM + END IF + JLAM = J + ELSE + K = K + 1 + W( K ) = Z( JLAM ) + DLAMDA( K ) = D( JLAM ) + INDXP( K ) = JLAM + JLAM = J + END IF + END IF + GO TO 80 + 100 CONTINUE +* +* Record the last eigenvalue. +* + K = K + 1 + W( K ) = Z( JLAM ) + DLAMDA( K ) = D( JLAM ) + INDXP( K ) = JLAM +* + 110 CONTINUE +* +* Sort the eigenvalues and corresponding eigenvectors into DLAMDA +* and Q2 respectively. The eigenvalues/vectors which were not +* deflated go into the first K slots of DLAMDA and Q2 respectively, +* while those which were deflated go into the last N - K slots. +* + IF( ICOMPQ.EQ.0 ) THEN + DO 120 J = 1, N + JP = INDXP( J ) + DLAMDA( J ) = D( JP ) + PERM( J ) = INDXQ( INDX( JP ) ) + 120 CONTINUE + ELSE + DO 130 J = 1, N + JP = INDXP( J ) + DLAMDA( J ) = D( JP ) + PERM( J ) = INDXQ( INDX( JP ) ) + CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) + 130 CONTINUE + END IF +* +* The deflated eigenvalues and their corresponding vectors go back +* into the last N - K slots of D and Q respectively. +* + IF( K.LT.N ) THEN + IF( ICOMPQ.EQ.0 ) THEN + CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) + ELSE + CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) + CALL DLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, + $ Q( 1, K+1 ), LDQ ) + END IF + END IF +* + RETURN +* +* End of DLAED8 +* + END diff --git a/math/lapack/src/main/fortran/dlaed9.f b/math/lapack/src/main/fortran/dlaed9.f new file mode 100644 index 0000000000..d3be22502a --- /dev/null +++ b/math/lapack/src/main/fortran/dlaed9.f @@ -0,0 +1,294 @@ +*> \brief \b DLAED9 used by sstedc. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is dense. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAED9 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, +* S, LDS, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N +* DOUBLE PRECISION RHO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), +* $ W( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAED9 finds the roots of the secular equation, as defined by the +*> values in D, Z, and RHO, between KSTART and KSTOP. It makes the +*> appropriate calls to DLAED4 and then stores the new matrix of +*> eigenvectors for use in calculating the next level of Z vectors. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of terms in the rational function to be solved by +*> DLAED4. K >= 0. +*> \endverbatim +*> +*> \param[in] KSTART +*> \verbatim +*> KSTART is INTEGER +*> \endverbatim +*> +*> \param[in] KSTOP +*> \verbatim +*> KSTOP is INTEGER +*> The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP +*> are to be computed. 1 <= KSTART <= KSTOP <= K. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns in the Q matrix. +*> N >= K (delation may result in N > K). +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> D(I) contains the updated eigenvalues +*> for KSTART <= I <= KSTOP. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ,N) +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= max( 1, N ). +*> \endverbatim +*> +*> \param[in] RHO +*> \verbatim +*> RHO is DOUBLE PRECISION +*> The value of the parameter in the rank one update equation. +*> RHO >= 0 required. +*> \endverbatim +*> +*> \param[in] DLAMDA +*> \verbatim +*> DLAMDA is DOUBLE PRECISION array, dimension (K) +*> The first K elements of this array contain the old roots +*> of the deflated updating problem. These are the poles +*> of the secular equation. +*> \endverbatim +*> +*> \param[in] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (K) +*> The first K elements of this array contain the components +*> of the deflation-adjusted updating vector. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (LDS, K) +*> Will contain the eigenvectors of the repaired matrix which +*> will be stored for subsequent Z vector calculation and +*> multiplied by the previously accumulated eigenvectors +*> to update the system. +*> \endverbatim +*> +*> \param[in] LDS +*> \verbatim +*> LDS is INTEGER +*> The leading dimension of S. LDS >= max( 1, K ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = 1, an eigenvalue did not converge +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Jeff Rutter, Computer Science Division, University of California +*> at Berkeley, USA +* +* ===================================================================== + SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, + $ S, LDS, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N + DOUBLE PRECISION RHO +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), + $ W( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION TEMP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3, DNRM2 + EXTERNAL DLAMC3, DNRM2 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLAED4, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( K.LT.0 ) THEN + INFO = -1 + ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN + INFO = -2 + ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) ) + $ THEN + INFO = -3 + ELSE IF( N.LT.K ) THEN + INFO = -4 + ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( LDS.LT.MAX( 1, K ) ) THEN + INFO = -12 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAED9', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( K.EQ.0 ) + $ RETURN +* +* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can +* be computed with high relative accuracy (barring over/underflow). +* This is a problem on machines without a guard digit in +* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). +* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), +* which on any of these machines zeros out the bottommost +* bit of DLAMDA(I) if it is 1; this makes the subsequent +* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation +* occurs. On binary machines with a guard digit (almost all +* machines) it does not change DLAMDA(I) at all. On hexadecimal +* and decimal machines with a guard digit, it slightly +* changes the bottommost bits of DLAMDA(I). It does not account +* for hexadecimal or decimal machines without guard digits +* (we know of none). We use a subroutine call to compute +* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating +* this code. +* + DO 10 I = 1, N + DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I ) + 10 CONTINUE +* + DO 20 J = KSTART, KSTOP + CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO ) +* +* If the zero finder fails, the computation is terminated. +* + IF( INFO.NE.0 ) + $ GO TO 120 + 20 CONTINUE +* + IF( K.EQ.1 .OR. K.EQ.2 ) THEN + DO 40 I = 1, K + DO 30 J = 1, K + S( J, I ) = Q( J, I ) + 30 CONTINUE + 40 CONTINUE + GO TO 120 + END IF +* +* Compute updated W. +* + CALL DCOPY( K, W, 1, S, 1 ) +* +* Initialize W(I) = Q(I,I) +* + CALL DCOPY( K, Q, LDQ+1, W, 1 ) + DO 70 J = 1, K + DO 50 I = 1, J - 1 + W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) + 50 CONTINUE + DO 60 I = J + 1, K + W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) + 60 CONTINUE + 70 CONTINUE + DO 80 I = 1, K + W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) ) + 80 CONTINUE +* +* Compute eigenvectors of the modified rank-1 modification. +* + DO 110 J = 1, K + DO 90 I = 1, K + Q( I, J ) = W( I ) / Q( I, J ) + 90 CONTINUE + TEMP = DNRM2( K, Q( 1, J ), 1 ) + DO 100 I = 1, K + S( I, J ) = Q( I, J ) / TEMP + 100 CONTINUE + 110 CONTINUE +* + 120 CONTINUE + RETURN +* +* End of DLAED9 +* + END diff --git a/math/lapack/src/main/fortran/dlaeda.f b/math/lapack/src/main/fortran/dlaeda.f new file mode 100644 index 0000000000..4ca08a0879 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaeda.f @@ -0,0 +1,308 @@ +*> \brief \b DLAEDA used by sstedc. Computes the Z vector determining the rank-one modification of the diagonal matrix. Used when the original matrix is dense. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAEDA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, +* GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) +* +* .. Scalar Arguments .. +* INTEGER CURLVL, CURPBM, INFO, N, TLVLS +* .. +* .. Array Arguments .. +* INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ), +* $ PRMPTR( * ), QPTR( * ) +* DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAEDA computes the Z vector corresponding to the merge step in the +*> CURLVLth step of the merge process with TLVLS steps for the CURPBMth +*> problem. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The dimension of the symmetric tridiagonal matrix. N >= 0. +*> \endverbatim +*> +*> \param[in] TLVLS +*> \verbatim +*> TLVLS is INTEGER +*> The total number of merging levels in the overall divide and +*> conquer tree. +*> \endverbatim +*> +*> \param[in] CURLVL +*> \verbatim +*> CURLVL is INTEGER +*> The current level in the overall merge routine, +*> 0 <= curlvl <= tlvls. +*> \endverbatim +*> +*> \param[in] CURPBM +*> \verbatim +*> CURPBM is INTEGER +*> The current problem in the current level in the overall +*> merge routine (counting from upper left to lower right). +*> \endverbatim +*> +*> \param[in] PRMPTR +*> \verbatim +*> PRMPTR is INTEGER array, dimension (N lg N) +*> Contains a list of pointers which indicate where in PERM a +*> level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) +*> indicates the size of the permutation and incidentally the +*> size of the full, non-deflated problem. +*> \endverbatim +*> +*> \param[in] PERM +*> \verbatim +*> PERM is INTEGER array, dimension (N lg N) +*> Contains the permutations (from deflation and sorting) to be +*> applied to each eigenblock. +*> \endverbatim +*> +*> \param[in] GIVPTR +*> \verbatim +*> GIVPTR is INTEGER array, dimension (N lg N) +*> Contains a list of pointers which indicate where in GIVCOL a +*> level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) +*> indicates the number of Givens rotations. +*> \endverbatim +*> +*> \param[in] GIVCOL +*> \verbatim +*> GIVCOL is INTEGER array, dimension (2, N lg N) +*> Each pair of numbers indicates a pair of columns to take place +*> in a Givens rotation. +*> \endverbatim +*> +*> \param[in] GIVNUM +*> \verbatim +*> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N) +*> Each number indicates the S value to be used in the +*> corresponding Givens rotation. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (N**2) +*> Contains the square eigenblocks from previous levels, the +*> starting positions for blocks are given by QPTR. +*> \endverbatim +*> +*> \param[in] QPTR +*> \verbatim +*> QPTR is INTEGER array, dimension (N+2) +*> Contains a list of pointers which indicate where in Q an +*> eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates +*> the size of the block. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (N) +*> On output this vector contains the updating vector (the last +*> row of the first sub-eigenvector matrix and the first row of +*> the second sub-eigenvector matrix). +*> \endverbatim +*> +*> \param[out] ZTEMP +*> \verbatim +*> ZTEMP is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Jeff Rutter, Computer Science Division, University of California +*> at Berkeley, USA +* +* ===================================================================== + SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, + $ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER CURLVL, CURPBM, INFO, N, TLVLS +* .. +* .. Array Arguments .. + INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ), + $ PRMPTR( * ), QPTR( * ) + DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2, + $ PTR, ZPTR1 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DROT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( N.LT.0 ) THEN + INFO = -1 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAEDA', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine location of first number in second half. +* + MID = N / 2 + 1 +* +* Gather last/first rows of appropriate eigenblocks into center of Z +* + PTR = 1 +* +* Determine location of lowest level subproblem in the full storage +* scheme +* + CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1 +* +* Determine size of these matrices. We add HALF to the value of +* the SQRT in case the machine underestimates one of these square +* roots. +* + BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) ) + BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) ) + DO 10 K = 1, MID - BSIZ1 - 1 + Z( K ) = ZERO + 10 CONTINUE + CALL DCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1, + $ Z( MID-BSIZ1 ), 1 ) + CALL DCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 ) + DO 20 K = MID + BSIZ2, N + Z( K ) = ZERO + 20 CONTINUE +* +* Loop through remaining levels 1 -> CURLVL applying the Givens +* rotations and permutation and then multiplying the center matrices +* against the current Z. +* + PTR = 2**TLVLS + 1 + DO 70 K = 1, CURLVL - 1 + CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1 + PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR ) + PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 ) + ZPTR1 = MID - PSIZ1 +* +* Apply Givens at CURR and CURR+1 +* + DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1 + CALL DROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1, + $ Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ), + $ GIVNUM( 2, I ) ) + 30 CONTINUE + DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1 + CALL DROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1, + $ Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ), + $ GIVNUM( 2, I ) ) + 40 CONTINUE + PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR ) + PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 ) + DO 50 I = 0, PSIZ1 - 1 + ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 ) + 50 CONTINUE + DO 60 I = 0, PSIZ2 - 1 + ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 ) + 60 CONTINUE +* +* Multiply Blocks at CURR and CURR+1 +* +* Determine size of these matrices. We add HALF to the value of +* the SQRT in case the machine underestimates one of these +* square roots. +* + BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) ) + BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+ + $ 1 ) ) ) ) + IF( BSIZ1.GT.0 ) THEN + CALL DGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ), + $ BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 ) + END IF + CALL DCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ), + $ 1 ) + IF( BSIZ2.GT.0 ) THEN + CALL DGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ), + $ BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 ) + END IF + CALL DCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1, + $ Z( MID+BSIZ2 ), 1 ) +* + PTR = PTR + 2**( TLVLS-K ) + 70 CONTINUE +* + RETURN +* +* End of DLAEDA +* + END diff --git a/math/lapack/src/main/fortran/dlaein.f b/math/lapack/src/main/fortran/dlaein.f new file mode 100644 index 0000000000..d35e186a1b --- /dev/null +++ b/math/lapack/src/main/fortran/dlaein.f @@ -0,0 +1,632 @@ +*> \brief \b DLAEIN computes a specified right or left eigenvector of an upper Hessenberg matrix by inverse iteration. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAEIN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, +* LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO ) +* +* .. Scalar Arguments .. +* LOGICAL NOINIT, RIGHTV +* INTEGER INFO, LDB, LDH, N +* DOUBLE PRECISION BIGNUM, EPS3, SMLNUM, WI, WR +* .. +* .. Array Arguments .. +* DOUBLE PRECISION B( LDB, * ), H( LDH, * ), VI( * ), VR( * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAEIN uses inverse iteration to find a right or left eigenvector +*> corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg +*> matrix H. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] RIGHTV +*> \verbatim +*> RIGHTV is LOGICAL +*> = .TRUE. : compute right eigenvector; +*> = .FALSE.: compute left eigenvector. +*> \endverbatim +*> +*> \param[in] NOINIT +*> \verbatim +*> NOINIT is LOGICAL +*> = .TRUE. : no initial vector supplied in (VR,VI). +*> = .FALSE.: initial vector supplied in (VR,VI). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H. N >= 0. +*> \endverbatim +*> +*> \param[in] H +*> \verbatim +*> H is DOUBLE PRECISION array, dimension (LDH,N) +*> The upper Hessenberg matrix H. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the array H. LDH >= max(1,N). +*> \endverbatim +*> +*> \param[in] WR +*> \verbatim +*> WR is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] WI +*> \verbatim +*> WI is DOUBLE PRECISION +*> The real and imaginary parts of the eigenvalue of H whose +*> corresponding right or left eigenvector is to be computed. +*> \endverbatim +*> +*> \param[in,out] VR +*> \verbatim +*> VR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[in,out] VI +*> \verbatim +*> VI is DOUBLE PRECISION array, dimension (N) +*> On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain +*> a real starting vector for inverse iteration using the real +*> eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI +*> must contain the real and imaginary parts of a complex +*> starting vector for inverse iteration using the complex +*> eigenvalue (WR,WI); otherwise VR and VI need not be set. +*> On exit, if WI = 0.0 (real eigenvalue), VR contains the +*> computed real eigenvector; if WI.ne.0.0 (complex eigenvalue), +*> VR and VI contain the real and imaginary parts of the +*> computed complex eigenvector. The eigenvector is normalized +*> so that the component of largest magnitude has magnitude 1; +*> here the magnitude of a complex number (x,y) is taken to be +*> |x| + |y|. +*> VI is not referenced if WI = 0.0. +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= N+1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[in] EPS3 +*> \verbatim +*> EPS3 is DOUBLE PRECISION +*> A small machine-dependent value which is used to perturb +*> close eigenvalues, and to replace zero pivots. +*> \endverbatim +*> +*> \param[in] SMLNUM +*> \verbatim +*> SMLNUM is DOUBLE PRECISION +*> A machine-dependent value close to the underflow threshold. +*> \endverbatim +*> +*> \param[in] BIGNUM +*> \verbatim +*> BIGNUM is DOUBLE PRECISION +*> A machine-dependent value close to the overflow threshold. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> = 1: inverse iteration did not converge; VR is set to the +*> last iterate, and so is VI if WI.ne.0.0. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, + $ LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + LOGICAL NOINIT, RIGHTV + INTEGER INFO, LDB, LDH, N + DOUBLE PRECISION BIGNUM, EPS3, SMLNUM, WI, WR +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), H( LDH, * ), VI( * ), VR( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TENTH + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TENTH = 1.0D-1 ) +* .. +* .. Local Scalars .. + CHARACTER NORMIN, TRANS + INTEGER I, I1, I2, I3, IERR, ITS, J + DOUBLE PRECISION ABSBII, ABSBJJ, EI, EJ, GROWTO, NORM, NRMSML, + $ REC, ROOTN, SCALE, TEMP, VCRIT, VMAX, VNORM, W, + $ W1, X, XI, XR, Y +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DASUM, DLAPY2, DNRM2 + EXTERNAL IDAMAX, DASUM, DLAPY2, DNRM2 +* .. +* .. External Subroutines .. + EXTERNAL DLADIV, DLATRS, DSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* GROWTO is the threshold used in the acceptance test for an +* eigenvector. +* + ROOTN = SQRT( DBLE( N ) ) + GROWTO = TENTH / ROOTN + NRMSML = MAX( ONE, EPS3*ROOTN )*SMLNUM +* +* Form B = H - (WR,WI)*I (except that the subdiagonal elements and +* the imaginary parts of the diagonal elements are not stored). +* + DO 20 J = 1, N + DO 10 I = 1, J - 1 + B( I, J ) = H( I, J ) + 10 CONTINUE + B( J, J ) = H( J, J ) - WR + 20 CONTINUE +* + IF( WI.EQ.ZERO ) THEN +* +* Real eigenvalue. +* + IF( NOINIT ) THEN +* +* Set initial vector. +* + DO 30 I = 1, N + VR( I ) = EPS3 + 30 CONTINUE + ELSE +* +* Scale supplied initial vector. +* + VNORM = DNRM2( N, VR, 1 ) + CALL DSCAL( N, ( EPS3*ROOTN ) / MAX( VNORM, NRMSML ), VR, + $ 1 ) + END IF +* + IF( RIGHTV ) THEN +* +* LU decomposition with partial pivoting of B, replacing zero +* pivots by EPS3. +* + DO 60 I = 1, N - 1 + EI = H( I+1, I ) + IF( ABS( B( I, I ) ).LT.ABS( EI ) ) THEN +* +* Interchange rows and eliminate. +* + X = B( I, I ) / EI + B( I, I ) = EI + DO 40 J = I + 1, N + TEMP = B( I+1, J ) + B( I+1, J ) = B( I, J ) - X*TEMP + B( I, J ) = TEMP + 40 CONTINUE + ELSE +* +* Eliminate without interchange. +* + IF( B( I, I ).EQ.ZERO ) + $ B( I, I ) = EPS3 + X = EI / B( I, I ) + IF( X.NE.ZERO ) THEN + DO 50 J = I + 1, N + B( I+1, J ) = B( I+1, J ) - X*B( I, J ) + 50 CONTINUE + END IF + END IF + 60 CONTINUE + IF( B( N, N ).EQ.ZERO ) + $ B( N, N ) = EPS3 +* + TRANS = 'N' +* + ELSE +* +* UL decomposition with partial pivoting of B, replacing zero +* pivots by EPS3. +* + DO 90 J = N, 2, -1 + EJ = H( J, J-1 ) + IF( ABS( B( J, J ) ).LT.ABS( EJ ) ) THEN +* +* Interchange columns and eliminate. +* + X = B( J, J ) / EJ + B( J, J ) = EJ + DO 70 I = 1, J - 1 + TEMP = B( I, J-1 ) + B( I, J-1 ) = B( I, J ) - X*TEMP + B( I, J ) = TEMP + 70 CONTINUE + ELSE +* +* Eliminate without interchange. +* + IF( B( J, J ).EQ.ZERO ) + $ B( J, J ) = EPS3 + X = EJ / B( J, J ) + IF( X.NE.ZERO ) THEN + DO 80 I = 1, J - 1 + B( I, J-1 ) = B( I, J-1 ) - X*B( I, J ) + 80 CONTINUE + END IF + END IF + 90 CONTINUE + IF( B( 1, 1 ).EQ.ZERO ) + $ B( 1, 1 ) = EPS3 +* + TRANS = 'T' +* + END IF +* + NORMIN = 'N' + DO 110 ITS = 1, N +* +* Solve U*x = scale*v for a right eigenvector +* or U**T*x = scale*v for a left eigenvector, +* overwriting x on v. +* + CALL DLATRS( 'Upper', TRANS, 'Nonunit', NORMIN, N, B, LDB, + $ VR, SCALE, WORK, IERR ) + NORMIN = 'Y' +* +* Test for sufficient growth in the norm of v. +* + VNORM = DASUM( N, VR, 1 ) + IF( VNORM.GE.GROWTO*SCALE ) + $ GO TO 120 +* +* Choose new orthogonal starting vector and try again. +* + TEMP = EPS3 / ( ROOTN+ONE ) + VR( 1 ) = EPS3 + DO 100 I = 2, N + VR( I ) = TEMP + 100 CONTINUE + VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN + 110 CONTINUE +* +* Failure to find eigenvector in N iterations. +* + INFO = 1 +* + 120 CONTINUE +* +* Normalize eigenvector. +* + I = IDAMAX( N, VR, 1 ) + CALL DSCAL( N, ONE / ABS( VR( I ) ), VR, 1 ) + ELSE +* +* Complex eigenvalue. +* + IF( NOINIT ) THEN +* +* Set initial vector. +* + DO 130 I = 1, N + VR( I ) = EPS3 + VI( I ) = ZERO + 130 CONTINUE + ELSE +* +* Scale supplied initial vector. +* + NORM = DLAPY2( DNRM2( N, VR, 1 ), DNRM2( N, VI, 1 ) ) + REC = ( EPS3*ROOTN ) / MAX( NORM, NRMSML ) + CALL DSCAL( N, REC, VR, 1 ) + CALL DSCAL( N, REC, VI, 1 ) + END IF +* + IF( RIGHTV ) THEN +* +* LU decomposition with partial pivoting of B, replacing zero +* pivots by EPS3. +* +* The imaginary part of the (i,j)-th element of U is stored in +* B(j+1,i). +* + B( 2, 1 ) = -WI + DO 140 I = 2, N + B( I+1, 1 ) = ZERO + 140 CONTINUE +* + DO 170 I = 1, N - 1 + ABSBII = DLAPY2( B( I, I ), B( I+1, I ) ) + EI = H( I+1, I ) + IF( ABSBII.LT.ABS( EI ) ) THEN +* +* Interchange rows and eliminate. +* + XR = B( I, I ) / EI + XI = B( I+1, I ) / EI + B( I, I ) = EI + B( I+1, I ) = ZERO + DO 150 J = I + 1, N + TEMP = B( I+1, J ) + B( I+1, J ) = B( I, J ) - XR*TEMP + B( J+1, I+1 ) = B( J+1, I ) - XI*TEMP + B( I, J ) = TEMP + B( J+1, I ) = ZERO + 150 CONTINUE + B( I+2, I ) = -WI + B( I+1, I+1 ) = B( I+1, I+1 ) - XI*WI + B( I+2, I+1 ) = B( I+2, I+1 ) + XR*WI + ELSE +* +* Eliminate without interchanging rows. +* + IF( ABSBII.EQ.ZERO ) THEN + B( I, I ) = EPS3 + B( I+1, I ) = ZERO + ABSBII = EPS3 + END IF + EI = ( EI / ABSBII ) / ABSBII + XR = B( I, I )*EI + XI = -B( I+1, I )*EI + DO 160 J = I + 1, N + B( I+1, J ) = B( I+1, J ) - XR*B( I, J ) + + $ XI*B( J+1, I ) + B( J+1, I+1 ) = -XR*B( J+1, I ) - XI*B( I, J ) + 160 CONTINUE + B( I+2, I+1 ) = B( I+2, I+1 ) - WI + END IF +* +* Compute 1-norm of offdiagonal elements of i-th row. +* + WORK( I ) = DASUM( N-I, B( I, I+1 ), LDB ) + + $ DASUM( N-I, B( I+2, I ), 1 ) + 170 CONTINUE + IF( B( N, N ).EQ.ZERO .AND. B( N+1, N ).EQ.ZERO ) + $ B( N, N ) = EPS3 + WORK( N ) = ZERO +* + I1 = N + I2 = 1 + I3 = -1 + ELSE +* +* UL decomposition with partial pivoting of conjg(B), +* replacing zero pivots by EPS3. +* +* The imaginary part of the (i,j)-th element of U is stored in +* B(j+1,i). +* + B( N+1, N ) = WI + DO 180 J = 1, N - 1 + B( N+1, J ) = ZERO + 180 CONTINUE +* + DO 210 J = N, 2, -1 + EJ = H( J, J-1 ) + ABSBJJ = DLAPY2( B( J, J ), B( J+1, J ) ) + IF( ABSBJJ.LT.ABS( EJ ) ) THEN +* +* Interchange columns and eliminate +* + XR = B( J, J ) / EJ + XI = B( J+1, J ) / EJ + B( J, J ) = EJ + B( J+1, J ) = ZERO + DO 190 I = 1, J - 1 + TEMP = B( I, J-1 ) + B( I, J-1 ) = B( I, J ) - XR*TEMP + B( J, I ) = B( J+1, I ) - XI*TEMP + B( I, J ) = TEMP + B( J+1, I ) = ZERO + 190 CONTINUE + B( J+1, J-1 ) = WI + B( J-1, J-1 ) = B( J-1, J-1 ) + XI*WI + B( J, J-1 ) = B( J, J-1 ) - XR*WI + ELSE +* +* Eliminate without interchange. +* + IF( ABSBJJ.EQ.ZERO ) THEN + B( J, J ) = EPS3 + B( J+1, J ) = ZERO + ABSBJJ = EPS3 + END IF + EJ = ( EJ / ABSBJJ ) / ABSBJJ + XR = B( J, J )*EJ + XI = -B( J+1, J )*EJ + DO 200 I = 1, J - 1 + B( I, J-1 ) = B( I, J-1 ) - XR*B( I, J ) + + $ XI*B( J+1, I ) + B( J, I ) = -XR*B( J+1, I ) - XI*B( I, J ) + 200 CONTINUE + B( J, J-1 ) = B( J, J-1 ) + WI + END IF +* +* Compute 1-norm of offdiagonal elements of j-th column. +* + WORK( J ) = DASUM( J-1, B( 1, J ), 1 ) + + $ DASUM( J-1, B( J+1, 1 ), LDB ) + 210 CONTINUE + IF( B( 1, 1 ).EQ.ZERO .AND. B( 2, 1 ).EQ.ZERO ) + $ B( 1, 1 ) = EPS3 + WORK( 1 ) = ZERO +* + I1 = 1 + I2 = N + I3 = 1 + END IF +* + DO 270 ITS = 1, N + SCALE = ONE + VMAX = ONE + VCRIT = BIGNUM +* +* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector, +* or U**T*(xr,xi) = scale*(vr,vi) for a left eigenvector, +* overwriting (xr,xi) on (vr,vi). +* + DO 250 I = I1, I2, I3 +* + IF( WORK( I ).GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N, REC, VR, 1 ) + CALL DSCAL( N, REC, VI, 1 ) + SCALE = SCALE*REC + VMAX = ONE + VCRIT = BIGNUM + END IF +* + XR = VR( I ) + XI = VI( I ) + IF( RIGHTV ) THEN + DO 220 J = I + 1, N + XR = XR - B( I, J )*VR( J ) + B( J+1, I )*VI( J ) + XI = XI - B( I, J )*VI( J ) - B( J+1, I )*VR( J ) + 220 CONTINUE + ELSE + DO 230 J = 1, I - 1 + XR = XR - B( J, I )*VR( J ) + B( I+1, J )*VI( J ) + XI = XI - B( J, I )*VI( J ) - B( I+1, J )*VR( J ) + 230 CONTINUE + END IF +* + W = ABS( B( I, I ) ) + ABS( B( I+1, I ) ) + IF( W.GT.SMLNUM ) THEN + IF( W.LT.ONE ) THEN + W1 = ABS( XR ) + ABS( XI ) + IF( W1.GT.W*BIGNUM ) THEN + REC = ONE / W1 + CALL DSCAL( N, REC, VR, 1 ) + CALL DSCAL( N, REC, VI, 1 ) + XR = VR( I ) + XI = VI( I ) + SCALE = SCALE*REC + VMAX = VMAX*REC + END IF + END IF +* +* Divide by diagonal element of B. +* + CALL DLADIV( XR, XI, B( I, I ), B( I+1, I ), VR( I ), + $ VI( I ) ) + VMAX = MAX( ABS( VR( I ) )+ABS( VI( I ) ), VMAX ) + VCRIT = BIGNUM / VMAX + ELSE + DO 240 J = 1, N + VR( J ) = ZERO + VI( J ) = ZERO + 240 CONTINUE + VR( I ) = ONE + VI( I ) = ONE + SCALE = ZERO + VMAX = ONE + VCRIT = BIGNUM + END IF + 250 CONTINUE +* +* Test for sufficient growth in the norm of (VR,VI). +* + VNORM = DASUM( N, VR, 1 ) + DASUM( N, VI, 1 ) + IF( VNORM.GE.GROWTO*SCALE ) + $ GO TO 280 +* +* Choose a new orthogonal starting vector and try again. +* + Y = EPS3 / ( ROOTN+ONE ) + VR( 1 ) = EPS3 + VI( 1 ) = ZERO +* + DO 260 I = 2, N + VR( I ) = Y + VI( I ) = ZERO + 260 CONTINUE + VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN + 270 CONTINUE +* +* Failure to find eigenvector in N iterations +* + INFO = 1 +* + 280 CONTINUE +* +* Normalize eigenvector. +* + VNORM = ZERO + DO 290 I = 1, N + VNORM = MAX( VNORM, ABS( VR( I ) )+ABS( VI( I ) ) ) + 290 CONTINUE + CALL DSCAL( N, ONE / VNORM, VR, 1 ) + CALL DSCAL( N, ONE / VNORM, VI, 1 ) +* + END IF +* + RETURN +* +* End of DLAEIN +* + END diff --git a/math/lapack/src/main/fortran/dlaev2.f b/math/lapack/src/main/fortran/dlaev2.f new file mode 100644 index 0000000000..4906f1a20c --- /dev/null +++ b/math/lapack/src/main/fortran/dlaev2.f @@ -0,0 +1,238 @@ +*> \brief \b DLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAEV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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 ]. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION +*> The (1,1) element of the 2-by-2 matrix. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION +*> The (1,2) element and the conjugate of the (2,1) element of +*> the 2-by-2 matrix. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION +*> The (2,2) element of the 2-by-2 matrix. +*> \endverbatim +*> +*> \param[out] RT1 +*> \verbatim +*> RT1 is DOUBLE PRECISION +*> The eigenvalue of larger absolute value. +*> \endverbatim +*> +*> \param[out] RT2 +*> \verbatim +*> RT2 is DOUBLE PRECISION +*> The eigenvalue of smaller absolute value. +*> \endverbatim +*> +*> \param[out] CS1 +*> \verbatim +*> CS1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] SN1 +*> \verbatim +*> SN1 is DOUBLE PRECISION +*> The vector (CS1, SN1) is a unit right eigenvector for RT1. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlaexc.f b/math/lapack/src/main/fortran/dlaexc.f new file mode 100644 index 0000000000..fc4f4a732c --- /dev/null +++ b/math/lapack/src/main/fortran/dlaexc.f @@ -0,0 +1,436 @@ +*> \brief \b DLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form, by an orthogonal similarity transformation. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAEXC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* LOGICAL WANTQ +* INTEGER INFO, J1, LDQ, LDT, N, N1, N2 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTQ +*> \verbatim +*> WANTQ is LOGICAL +*> = .TRUE. : accumulate the transformation in the matrix Q; +*> = .FALSE.: do not accumulate the transformation. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in,out] T +*> \verbatim +*> T is 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. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is 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. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. +*> LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. +*> \endverbatim +*> +*> \param[in] J1 +*> \verbatim +*> J1 is INTEGER +*> The index of the first row of the first block T11. +*> \endverbatim +*> +*> \param[in] N1 +*> \verbatim +*> N1 is INTEGER +*> The order of the first block T11. N1 = 0, 1 or 2. +*> \endverbatim +*> +*> \param[in] N2 +*> \verbatim +*> N2 is INTEGER +*> The order of the second block T22. N2 = 0, 1 or 2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, + $ INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + LOGICAL WANTQ + INTEGER INFO, J1, LDQ, LDT, N, N1, N2 +* .. +* .. Array Arguments .. + DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlag2.f b/math/lapack/src/main/fortran/dlag2.f new file mode 100644 index 0000000000..7f123b2761 --- /dev/null +++ b/math/lapack/src/main/fortran/dlag2.f @@ -0,0 +1,379 @@ +*> \brief \b DLAG2 computes the eigenvalues of a 2-by-2 generalized eigenvalue problem, with scaling as necessary to avoid over-/underflow. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAG2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, +* WR2, WI ) +* +* .. Scalar Arguments .. +* INTEGER LDA, LDB +* DOUBLE PRECISION SAFMIN, SCALE1, SCALE2, WI, WR1, WR2 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= 2. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= 2. +*> \endverbatim +*> +*> \param[in] SAFMIN +*> \verbatim +*> SAFMIN is 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.) +*> \endverbatim +*> +*> \param[out] SCALE1 +*> \verbatim +*> SCALE1 is 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 threshold if the exact eigenvalue +*> is sufficiently large. +*> \endverbatim +*> +*> \param[out] SCALE2 +*> \verbatim +*> SCALE2 is 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 +*> threshold if the exact eigenvalue is sufficiently large. +*> \endverbatim +*> +*> \param[out] WR1 +*> \verbatim +*> WR1 is 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. +*> \endverbatim +*> +*> \param[out] WR2 +*> \verbatim +*> WR2 is 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. +*> \endverbatim +*> +*> \param[out] WI +*> \verbatim +*> WI is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, + $ WR2, WI ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER LDA, LDB + DOUBLE PRECISION SAFMIN, SCALE1, SCALE2, WI, WR1, WR2 +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. 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 threshold and handle numbers above that +* threshold 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/math/lapack/src/main/fortran/dlag2s.f b/math/lapack/src/main/fortran/dlag2s.f new file mode 100644 index 0000000000..09e2ac7718 --- /dev/null +++ b/math/lapack/src/main/fortran/dlag2s.f @@ -0,0 +1,152 @@ +*> \brief \b DLAG2S converts a double precision matrix to a single precision matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAG2S + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAG2S( M, N, A, LDA, SA, LDSA, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDSA, M, N +* .. +* .. Array Arguments .. +* REAL SA( LDSA, * ) +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAG2S converts a DOUBLE PRECISION matrix, SA, to a SINGLE +*> PRECISION matrix, A. +*> +*> RMAX is the overflow for the SINGLE PRECISION arithmetic +*> DLAG2S checks that all the entries of A are between -RMAX and +*> RMAX. If not the conversion is aborted and a flag is raised. +*> +*> This is an auxiliary routine so there is no argument checking. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of lines of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N coefficient matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] SA +*> \verbatim +*> SA is REAL array, dimension (LDSA,N) +*> On exit, if INFO=0, the M-by-N coefficient matrix SA; if +*> INFO>0, the content of SA is unspecified. +*> \endverbatim +*> +*> \param[in] LDSA +*> \verbatim +*> LDSA is INTEGER +*> The leading dimension of the array SA. LDSA >= max(1,M). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> = 1: an entry of the matrix A is greater than the SINGLE +*> PRECISION overflow threshold, in this case, the content +*> of SA in exit is unspecified. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAG2S( M, N, A, LDA, SA, LDSA, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDSA, M, N +* .. +* .. Array Arguments .. + REAL SA( LDSA, * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION RMAX +* .. +* .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH +* .. +* .. Executable Statements .. +* + RMAX = SLAMCH( 'O' ) + DO 20 J = 1, N + DO 10 I = 1, M + IF( ( A( I, J ).LT.-RMAX ) .OR. ( A( I, J ).GT.RMAX ) ) THEN + INFO = 1 + GO TO 30 + END IF + SA( I, J ) = A( I, J ) + 10 CONTINUE + 20 CONTINUE + INFO = 0 + 30 CONTINUE + RETURN +* +* End of DLAG2S +* + END diff --git a/math/lapack/src/main/fortran/dlags2.f b/math/lapack/src/main/fortran/dlags2.f new file mode 100644 index 0000000000..62a8334617 --- /dev/null +++ b/math/lapack/src/main/fortran/dlags2.f @@ -0,0 +1,362 @@ +*> \brief \b DLAGS2 computes 2-by-2 orthogonal matrices U, V, and Q, and applies them to matrices A and B such that the rows of the transformed A and B are parallel. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAGS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, +* SNV, CSQ, SNQ ) +* +* .. Scalar Arguments .. +* LOGICAL UPPER +* DOUBLE PRECISION A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ, +* $ SNU, SNV +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such +*> that if ( UPPER ) then +*> +*> U**T *A*Q = U**T *( A1 A2 )*Q = ( x 0 ) +*> ( 0 A3 ) ( x x ) +*> and +*> V**T*B*Q = V**T *( B1 B2 )*Q = ( x 0 ) +*> ( 0 B3 ) ( x x ) +*> +*> or if ( .NOT.UPPER ) then +*> +*> U**T *A*Q = U**T *( A1 0 )*Q = ( x x ) +*> ( A2 A3 ) ( 0 x ) +*> and +*> V**T*B*Q = V**T*( B1 0 )*Q = ( x x ) +*> ( B2 B3 ) ( 0 x ) +*> +*> The rows of the transformed A and B are parallel, where +*> +*> U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ ) +*> ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ ) +*> +*> Z**T denotes the transpose of Z. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPPER +*> \verbatim +*> UPPER is LOGICAL +*> = .TRUE.: the input matrices A and B are upper triangular. +*> = .FALSE.: the input matrices A and B are lower triangular. +*> \endverbatim +*> +*> \param[in] A1 +*> \verbatim +*> A1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] A2 +*> \verbatim +*> A2 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] A3 +*> \verbatim +*> A3 is DOUBLE PRECISION +*> On entry, A1, A2 and A3 are elements of the input 2-by-2 +*> upper (lower) triangular matrix A. +*> \endverbatim +*> +*> \param[in] B1 +*> \verbatim +*> B1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] B2 +*> \verbatim +*> B2 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] B3 +*> \verbatim +*> B3 is DOUBLE PRECISION +*> On entry, B1, B2 and B3 are elements of the input 2-by-2 +*> upper (lower) triangular matrix B. +*> \endverbatim +*> +*> \param[out] CSU +*> \verbatim +*> CSU is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] SNU +*> \verbatim +*> SNU is DOUBLE PRECISION +*> The desired orthogonal matrix U. +*> \endverbatim +*> +*> \param[out] CSV +*> \verbatim +*> CSV is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] SNV +*> \verbatim +*> SNV is DOUBLE PRECISION +*> The desired orthogonal matrix V. +*> \endverbatim +*> +*> \param[out] CSQ +*> \verbatim +*> CSQ is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] SNQ +*> \verbatim +*> SNQ is DOUBLE PRECISION +*> The desired orthogonal matrix Q. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, + $ SNV, CSQ, SNQ ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + LOGICAL UPPER + DOUBLE PRECISION A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ, + $ SNU, SNV +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12, + $ AVB21, AVB22, B, C, CSL, CSR, D, R, S1, S2, + $ SNL, SNR, UA11, UA11R, UA12, UA21, UA22, UA22R, + $ VB11, VB11R, VB12, VB21, VB22, VB22R +* .. +* .. External Subroutines .. + EXTERNAL DLARTG, DLASV2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + IF( UPPER ) THEN +* +* Input matrices A and B are upper triangular matrices +* +* Form matrix C = A*adj(B) = ( a b ) +* ( 0 d ) +* + A = A1*B3 + D = A3*B1 + B = A2*B1 - A1*B2 +* +* The SVD of real 2-by-2 triangular C +* +* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 ) +* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T ) +* + CALL DLASV2( A, B, D, S1, S2, SNR, CSR, SNL, CSL ) +* + IF( ABS( CSL ).GE.ABS( SNL ) .OR. ABS( CSR ).GE.ABS( SNR ) ) + $ THEN +* +* Compute the (1,1) and (1,2) elements of U**T *A and V**T *B, +* and (1,2) element of |U|**T *|A| and |V|**T *|B|. +* + UA11R = CSL*A1 + UA12 = CSL*A2 + SNL*A3 +* + VB11R = CSR*B1 + VB12 = CSR*B2 + SNR*B3 +* + AUA12 = ABS( CSL )*ABS( A2 ) + ABS( SNL )*ABS( A3 ) + AVB12 = ABS( CSR )*ABS( B2 ) + ABS( SNR )*ABS( B3 ) +* +* zero (1,2) elements of U**T *A and V**T *B +* + IF( ( ABS( UA11R )+ABS( UA12 ) ).NE.ZERO ) THEN + IF( AUA12 / ( ABS( UA11R )+ABS( UA12 ) ).LE.AVB12 / + $ ( ABS( VB11R )+ABS( VB12 ) ) ) THEN + CALL DLARTG( -UA11R, UA12, CSQ, SNQ, R ) + ELSE + CALL DLARTG( -VB11R, VB12, CSQ, SNQ, R ) + END IF + ELSE + CALL DLARTG( -VB11R, VB12, CSQ, SNQ, R ) + END IF +* + CSU = CSL + SNU = -SNL + CSV = CSR + SNV = -SNR +* + ELSE +* +* Compute the (2,1) and (2,2) elements of U**T *A and V**T *B, +* and (2,2) element of |U|**T *|A| and |V|**T *|B|. +* + UA21 = -SNL*A1 + UA22 = -SNL*A2 + CSL*A3 +* + VB21 = -SNR*B1 + VB22 = -SNR*B2 + CSR*B3 +* + AUA22 = ABS( SNL )*ABS( A2 ) + ABS( CSL )*ABS( A3 ) + AVB22 = ABS( SNR )*ABS( B2 ) + ABS( CSR )*ABS( B3 ) +* +* zero (2,2) elements of U**T*A and V**T*B, and then swap. +* + IF( ( ABS( UA21 )+ABS( UA22 ) ).NE.ZERO ) THEN + IF( AUA22 / ( ABS( UA21 )+ABS( UA22 ) ).LE.AVB22 / + $ ( ABS( VB21 )+ABS( VB22 ) ) ) THEN + CALL DLARTG( -UA21, UA22, CSQ, SNQ, R ) + ELSE + CALL DLARTG( -VB21, VB22, CSQ, SNQ, R ) + END IF + ELSE + CALL DLARTG( -VB21, VB22, CSQ, SNQ, R ) + END IF +* + CSU = SNL + SNU = CSL + CSV = SNR + SNV = CSR +* + END IF +* + ELSE +* +* Input matrices A and B are lower triangular matrices +* +* Form matrix C = A*adj(B) = ( a 0 ) +* ( c d ) +* + A = A1*B3 + D = A3*B1 + C = A2*B3 - A3*B2 +* +* The SVD of real 2-by-2 triangular C +* +* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 ) +* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T ) +* + CALL DLASV2( A, C, D, S1, S2, SNR, CSR, SNL, CSL ) +* + IF( ABS( CSR ).GE.ABS( SNR ) .OR. ABS( CSL ).GE.ABS( SNL ) ) + $ THEN +* +* Compute the (2,1) and (2,2) elements of U**T *A and V**T *B, +* and (2,1) element of |U|**T *|A| and |V|**T *|B|. +* + UA21 = -SNR*A1 + CSR*A2 + UA22R = CSR*A3 +* + VB21 = -SNL*B1 + CSL*B2 + VB22R = CSL*B3 +* + AUA21 = ABS( SNR )*ABS( A1 ) + ABS( CSR )*ABS( A2 ) + AVB21 = ABS( SNL )*ABS( B1 ) + ABS( CSL )*ABS( B2 ) +* +* zero (2,1) elements of U**T *A and V**T *B. +* + IF( ( ABS( UA21 )+ABS( UA22R ) ).NE.ZERO ) THEN + IF( AUA21 / ( ABS( UA21 )+ABS( UA22R ) ).LE.AVB21 / + $ ( ABS( VB21 )+ABS( VB22R ) ) ) THEN + CALL DLARTG( UA22R, UA21, CSQ, SNQ, R ) + ELSE + CALL DLARTG( VB22R, VB21, CSQ, SNQ, R ) + END IF + ELSE + CALL DLARTG( VB22R, VB21, CSQ, SNQ, R ) + END IF +* + CSU = CSR + SNU = -SNR + CSV = CSL + SNV = -SNL +* + ELSE +* +* Compute the (1,1) and (1,2) elements of U**T *A and V**T *B, +* and (1,1) element of |U|**T *|A| and |V|**T *|B|. +* + UA11 = CSR*A1 + SNR*A2 + UA12 = SNR*A3 +* + VB11 = CSL*B1 + SNL*B2 + VB12 = SNL*B3 +* + AUA11 = ABS( CSR )*ABS( A1 ) + ABS( SNR )*ABS( A2 ) + AVB11 = ABS( CSL )*ABS( B1 ) + ABS( SNL )*ABS( B2 ) +* +* zero (1,1) elements of U**T*A and V**T*B, and then swap. +* + IF( ( ABS( UA11 )+ABS( UA12 ) ).NE.ZERO ) THEN + IF( AUA11 / ( ABS( UA11 )+ABS( UA12 ) ).LE.AVB11 / + $ ( ABS( VB11 )+ABS( VB12 ) ) ) THEN + CALL DLARTG( UA12, UA11, CSQ, SNQ, R ) + ELSE + CALL DLARTG( VB12, VB11, CSQ, SNQ, R ) + END IF + ELSE + CALL DLARTG( VB12, VB11, CSQ, SNQ, R ) + END IF +* + CSU = SNR + SNU = CSR + CSV = SNL + SNV = CSL +* + END IF +* + END IF +* + RETURN +* +* End of DLAGS2 +* + END diff --git a/math/lapack/src/main/fortran/dlagtf.f b/math/lapack/src/main/fortran/dlagtf.f new file mode 100644 index 0000000000..4b257c64f3 --- /dev/null +++ b/math/lapack/src/main/fortran/dlagtf.f @@ -0,0 +1,266 @@ +*> \brief \b DLAGTF computes an LU factorization of a matrix T-λI, where T is a general tridiagonal matrix, and λ a scalar, using partial pivoting with row interchanges. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAGTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, N +* DOUBLE PRECISION LAMBDA, TOL +* .. +* .. Array Arguments .. +* INTEGER IN( * ) +* DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n +*> tridiagonal matrix and lambda is a scalar, as +*> +*> T - lambda*I = PLU, +*> +*> where P is a permutation matrix, L is a unit lower tridiagonal matrix +*> with at most one non-zero sub-diagonal elements per column and U is +*> an upper triangular matrix with at most two non-zero super-diagonal +*> elements per column. +*> +*> The factorization is obtained by Gaussian elimination with partial +*> pivoting and implicit row scaling. +*> +*> The parameter LAMBDA is included in the routine so that DLAGTF may +*> be used, in conjunction with DLAGTS, to obtain eigenvectors of T by +*> inverse iteration. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (N) +*> On entry, A must contain the diagonal elements of T. +*> +*> On exit, A is overwritten by the n diagonal elements of the +*> upper triangular matrix U of the factorization of T. +*> \endverbatim +*> +*> \param[in] LAMBDA +*> \verbatim +*> LAMBDA is DOUBLE PRECISION +*> On entry, the scalar lambda. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (N-1) +*> On entry, B must contain the (n-1) super-diagonal elements of +*> T. +*> +*> On exit, B is overwritten by the (n-1) super-diagonal +*> elements of the matrix U of the factorization of T. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N-1) +*> On entry, C must contain the (n-1) sub-diagonal elements of +*> T. +*> +*> On exit, C is overwritten by the (n-1) sub-diagonal elements +*> of the matrix L of the factorization of T. +*> \endverbatim +*> +*> \param[in] TOL +*> \verbatim +*> TOL is DOUBLE PRECISION +*> On entry, a relative tolerance used to indicate whether or +*> not the matrix (T - lambda*I) is nearly singular. TOL should +*> normally be chose as approximately the largest relative error +*> in the elements of T. For example, if the elements of T are +*> correct to about 4 significant figures, then TOL should be +*> set to about 5*10**(-4). If TOL is supplied as less than eps, +*> where eps is the relative machine precision, then the value +*> eps is used in place of TOL. +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N-2) +*> On exit, D is overwritten by the (n-2) second super-diagonal +*> elements of the matrix U of the factorization of T. +*> \endverbatim +*> +*> \param[out] IN +*> \verbatim +*> IN is INTEGER array, dimension (N) +*> On exit, IN contains details of the permutation matrix P. If +*> an interchange occurred at the kth step of the elimination, +*> then IN(k) = 1, otherwise IN(k) = 0. The element IN(n) +*> returns the smallest positive integer j such that +*> +*> abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL, +*> +*> where norm( A(j) ) denotes the sum of the absolute values of +*> the jth row of the matrix A. If no such j exists then IN(n) +*> is returned as zero. If IN(n) is returned as positive, then a +*> diagonal element of U is small, indicating that +*> (T - lambda*I) is singular or nearly singular, +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0 : successful exit +*> .lt. 0: if INFO = -k, the kth argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, N + DOUBLE PRECISION LAMBDA, TOL +* .. +* .. Array Arguments .. + INTEGER IN( * ) + DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER K + DOUBLE PRECISION EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + CALL XERBLA( 'DLAGTF', -INFO ) + RETURN + END IF +* + IF( N.EQ.0 ) + $ RETURN +* + A( 1 ) = A( 1 ) - LAMBDA + IN( N ) = 0 + IF( N.EQ.1 ) THEN + IF( A( 1 ).EQ.ZERO ) + $ IN( 1 ) = 1 + RETURN + END IF +* + EPS = DLAMCH( 'Epsilon' ) +* + TL = MAX( TOL, EPS ) + SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) ) + DO 10 K = 1, N - 1 + A( K+1 ) = A( K+1 ) - LAMBDA + SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) ) + IF( K.LT.( N-1 ) ) + $ SCALE2 = SCALE2 + ABS( B( K+1 ) ) + IF( A( K ).EQ.ZERO ) THEN + PIV1 = ZERO + ELSE + PIV1 = ABS( A( K ) ) / SCALE1 + END IF + IF( C( K ).EQ.ZERO ) THEN + IN( K ) = 0 + PIV2 = ZERO + SCALE1 = SCALE2 + IF( K.LT.( N-1 ) ) + $ D( K ) = ZERO + ELSE + PIV2 = ABS( C( K ) ) / SCALE2 + IF( PIV2.LE.PIV1 ) THEN + IN( K ) = 0 + SCALE1 = SCALE2 + C( K ) = C( K ) / A( K ) + A( K+1 ) = A( K+1 ) - C( K )*B( K ) + IF( K.LT.( N-1 ) ) + $ D( K ) = ZERO + ELSE + IN( K ) = 1 + MULT = A( K ) / C( K ) + A( K ) = C( K ) + TEMP = A( K+1 ) + A( K+1 ) = B( K ) - MULT*TEMP + IF( K.LT.( N-1 ) ) THEN + D( K ) = B( K+1 ) + B( K+1 ) = -MULT*D( K ) + END IF + B( K ) = TEMP + C( K ) = MULT + END IF + END IF + IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) ) + $ IN( N ) = K + 10 CONTINUE + IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) ) + $ IN( N ) = N +* + RETURN +* +* End of DLAGTF +* + END diff --git a/math/lapack/src/main/fortran/dlagtm.f b/math/lapack/src/main/fortran/dlagtm.f new file mode 100644 index 0000000000..bb330e8582 --- /dev/null +++ b/math/lapack/src/main/fortran/dlagtm.f @@ -0,0 +1,278 @@ +*> \brief \b DLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix, B and C are rectangular matrices, and α and β are scalars, which may be 0, 1, or -1. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAGTM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, +* B, LDB ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* INTEGER LDB, LDX, N, NRHS +* DOUBLE PRECISION ALPHA, BETA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), +* $ X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAGTM performs a matrix-vector product of the form +*> +*> B := alpha * A * X + beta * B +*> +*> where A is a tridiagonal matrix of order N, B and X are N by NRHS +*> matrices, and alpha and beta are real scalars, each of which may be +*> 0., 1., or -1. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the operation applied to A. +*> = 'N': No transpose, B := alpha * A * X + beta * B +*> = 'T': Transpose, B := alpha * A'* X + beta * B +*> = 'C': Conjugate transpose = Transpose +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices X and B. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise, +*> it is assumed to be 0. +*> \endverbatim +*> +*> \param[in] DL +*> \verbatim +*> DL is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) sub-diagonal elements of T. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of T. +*> \endverbatim +*> +*> \param[in] DU +*> \verbatim +*> DU is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) super-diagonal elements of T. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> The N by NRHS matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(N,1). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION +*> The scalar beta. BETA must be 0., 1., or -1.; otherwise, +*> it is assumed to be 1. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N by NRHS matrix B. +*> On exit, B is overwritten by the matrix expression +*> B := alpha * A * X + beta * B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(N,1). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, + $ B, LDB ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER LDB, LDX, N, NRHS + DOUBLE PRECISION ALPHA, BETA +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), + $ X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* + IF( N.EQ.0 ) + $ RETURN +* +* Multiply B by BETA if BETA.NE.1. +* + IF( BETA.EQ.ZERO ) THEN + DO 20 J = 1, NRHS + DO 10 I = 1, N + B( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE IF( BETA.EQ.-ONE ) THEN + DO 40 J = 1, NRHS + DO 30 I = 1, N + B( I, J ) = -B( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF +* + IF( ALPHA.EQ.ONE ) THEN + IF( LSAME( TRANS, 'N' ) ) THEN +* +* Compute B := B + A*X +* + DO 60 J = 1, NRHS + IF( N.EQ.1 ) THEN + B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) + ELSE + B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) + + $ DU( 1 )*X( 2, J ) + B( N, J ) = B( N, J ) + DL( N-1 )*X( N-1, J ) + + $ D( N )*X( N, J ) + DO 50 I = 2, N - 1 + B( I, J ) = B( I, J ) + DL( I-1 )*X( I-1, J ) + + $ D( I )*X( I, J ) + DU( I )*X( I+1, J ) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE +* +* Compute B := B + A**T*X +* + DO 80 J = 1, NRHS + IF( N.EQ.1 ) THEN + B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) + ELSE + B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) + + $ DL( 1 )*X( 2, J ) + B( N, J ) = B( N, J ) + DU( N-1 )*X( N-1, J ) + + $ D( N )*X( N, J ) + DO 70 I = 2, N - 1 + B( I, J ) = B( I, J ) + DU( I-1 )*X( I-1, J ) + + $ D( I )*X( I, J ) + DL( I )*X( I+1, J ) + 70 CONTINUE + END IF + 80 CONTINUE + END IF + ELSE IF( ALPHA.EQ.-ONE ) THEN + IF( LSAME( TRANS, 'N' ) ) THEN +* +* Compute B := B - A*X +* + DO 100 J = 1, NRHS + IF( N.EQ.1 ) THEN + B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) + ELSE + B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) - + $ DU( 1 )*X( 2, J ) + B( N, J ) = B( N, J ) - DL( N-1 )*X( N-1, J ) - + $ D( N )*X( N, J ) + DO 90 I = 2, N - 1 + B( I, J ) = B( I, J ) - DL( I-1 )*X( I-1, J ) - + $ D( I )*X( I, J ) - DU( I )*X( I+1, J ) + 90 CONTINUE + END IF + 100 CONTINUE + ELSE +* +* Compute B := B - A**T*X +* + DO 120 J = 1, NRHS + IF( N.EQ.1 ) THEN + B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) + ELSE + B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) - + $ DL( 1 )*X( 2, J ) + B( N, J ) = B( N, J ) - DU( N-1 )*X( N-1, J ) - + $ D( N )*X( N, J ) + DO 110 I = 2, N - 1 + B( I, J ) = B( I, J ) - DU( I-1 )*X( I-1, J ) - + $ D( I )*X( I, J ) - DL( I )*X( I+1, J ) + 110 CONTINUE + END IF + 120 CONTINUE + END IF + END IF + RETURN +* +* End of DLAGTM +* + END diff --git a/math/lapack/src/main/fortran/dlagts.f b/math/lapack/src/main/fortran/dlagts.f new file mode 100644 index 0000000000..926075827b --- /dev/null +++ b/math/lapack/src/main/fortran/dlagts.f @@ -0,0 +1,383 @@ +*> \brief \b DLAGTS solves the system of equations (T-λI)x = y or (T-λI)Tx = y,where T is a general tridiagonal matrix and λ a scalar, using the LU factorization computed by slagtf. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAGTS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, JOB, N +* DOUBLE PRECISION TOL +* .. +* .. Array Arguments .. +* INTEGER IN( * ) +* DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ), Y( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAGTS may be used to solve one of the systems of equations +*> +*> (T - lambda*I)*x = y or (T - lambda*I)**T*x = y, +*> +*> where T is an n by n tridiagonal matrix, for x, following the +*> factorization of (T - lambda*I) as +*> +*> (T - lambda*I) = P*L*U , +*> +*> by routine DLAGTF. The choice of equation to be solved is +*> controlled by the argument JOB, and in each case there is an option +*> to perturb zero or very small diagonal elements of U, this option +*> being intended for use in applications such as inverse iteration. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is INTEGER +*> Specifies the job to be performed by DLAGTS as follows: +*> = 1: The equations (T - lambda*I)x = y are to be solved, +*> but diagonal elements of U are not to be perturbed. +*> = -1: The equations (T - lambda*I)x = y are to be solved +*> and, if overflow would otherwise occur, the diagonal +*> elements of U are to be perturbed. See argument TOL +*> below. +*> = 2: The equations (T - lambda*I)**Tx = y are to be solved, +*> but diagonal elements of U are not to be perturbed. +*> = -2: The equations (T - lambda*I)**Tx = y are to be solved +*> and, if overflow would otherwise occur, the diagonal +*> elements of U are to be perturbed. See argument TOL +*> below. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (N) +*> On entry, A must contain the diagonal elements of U as +*> returned from DLAGTF. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (N-1) +*> On entry, B must contain the first super-diagonal elements of +*> U as returned from DLAGTF. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N-1) +*> On entry, C must contain the sub-diagonal elements of L as +*> returned from DLAGTF. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N-2) +*> On entry, D must contain the second super-diagonal elements +*> of U as returned from DLAGTF. +*> \endverbatim +*> +*> \param[in] IN +*> \verbatim +*> IN is INTEGER array, dimension (N) +*> On entry, IN must contain details of the matrix P as returned +*> from DLAGTF. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension (N) +*> On entry, the right hand side vector y. +*> On exit, Y is overwritten by the solution vector x. +*> \endverbatim +*> +*> \param[in,out] TOL +*> \verbatim +*> TOL is DOUBLE PRECISION +*> On entry, with JOB .lt. 0, TOL should be the minimum +*> perturbation to be made to very small diagonal elements of U. +*> TOL should normally be chosen as about eps*norm(U), where eps +*> is the relative machine precision, but if TOL is supplied as +*> non-positive, then it is reset to eps*max( abs( u(i,j) ) ). +*> If JOB .gt. 0 then TOL is not referenced. +*> +*> On exit, TOL is changed as described above, only if TOL is +*> non-positive on entry. Otherwise TOL is unchanged. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0 : successful exit +*> .lt. 0: if INFO = -i, the i-th argument had an illegal value +*> .gt. 0: overflow would occur when computing the INFO(th) +*> element of the solution vector x. This can only occur +*> when JOB is supplied as positive and either means +*> that a diagonal element of U is very small, or that +*> the elements of the right-hand side vector y are very +*> large. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, JOB, N + DOUBLE PRECISION TOL +* .. +* .. Array Arguments .. + INTEGER IN( * ) + DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ), Y( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER K + DOUBLE PRECISION ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAGTS', -INFO ) + RETURN + END IF +* + IF( N.EQ.0 ) + $ RETURN +* + EPS = DLAMCH( 'Epsilon' ) + SFMIN = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SFMIN +* + IF( JOB.LT.0 ) THEN + IF( TOL.LE.ZERO ) THEN + TOL = ABS( A( 1 ) ) + IF( N.GT.1 ) + $ TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) ) + DO 10 K = 3, N + TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ), + $ ABS( D( K-2 ) ) ) + 10 CONTINUE + TOL = TOL*EPS + IF( TOL.EQ.ZERO ) + $ TOL = EPS + END IF + END IF +* + IF( ABS( JOB ).EQ.1 ) THEN + DO 20 K = 2, N + IF( IN( K-1 ).EQ.0 ) THEN + Y( K ) = Y( K ) - C( K-1 )*Y( K-1 ) + ELSE + TEMP = Y( K-1 ) + Y( K-1 ) = Y( K ) + Y( K ) = TEMP - C( K-1 )*Y( K ) + END IF + 20 CONTINUE + IF( JOB.EQ.1 ) THEN + DO 30 K = N, 1, -1 + IF( K.LE.N-2 ) THEN + TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 ) + ELSE IF( K.EQ.N-1 ) THEN + TEMP = Y( K ) - B( K )*Y( K+1 ) + ELSE + TEMP = Y( K ) + END IF + AK = A( K ) + ABSAK = ABS( AK ) + IF( ABSAK.LT.ONE ) THEN + IF( ABSAK.LT.SFMIN ) THEN + IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) + $ THEN + INFO = K + RETURN + ELSE + TEMP = TEMP*BIGNUM + AK = AK*BIGNUM + END IF + ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN + INFO = K + RETURN + END IF + END IF + Y( K ) = TEMP / AK + 30 CONTINUE + ELSE + DO 50 K = N, 1, -1 + IF( K.LE.N-2 ) THEN + TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 ) + ELSE IF( K.EQ.N-1 ) THEN + TEMP = Y( K ) - B( K )*Y( K+1 ) + ELSE + TEMP = Y( K ) + END IF + AK = A( K ) + PERT = SIGN( TOL, AK ) + 40 CONTINUE + ABSAK = ABS( AK ) + IF( ABSAK.LT.ONE ) THEN + IF( ABSAK.LT.SFMIN ) THEN + IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) + $ THEN + AK = AK + PERT + PERT = 2*PERT + GO TO 40 + ELSE + TEMP = TEMP*BIGNUM + AK = AK*BIGNUM + END IF + ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN + AK = AK + PERT + PERT = 2*PERT + GO TO 40 + END IF + END IF + Y( K ) = TEMP / AK + 50 CONTINUE + END IF + ELSE +* +* Come to here if JOB = 2 or -2 +* + IF( JOB.EQ.2 ) THEN + DO 60 K = 1, N + IF( K.GE.3 ) THEN + TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 ) + ELSE IF( K.EQ.2 ) THEN + TEMP = Y( K ) - B( K-1 )*Y( K-1 ) + ELSE + TEMP = Y( K ) + END IF + AK = A( K ) + ABSAK = ABS( AK ) + IF( ABSAK.LT.ONE ) THEN + IF( ABSAK.LT.SFMIN ) THEN + IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) + $ THEN + INFO = K + RETURN + ELSE + TEMP = TEMP*BIGNUM + AK = AK*BIGNUM + END IF + ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN + INFO = K + RETURN + END IF + END IF + Y( K ) = TEMP / AK + 60 CONTINUE + ELSE + DO 80 K = 1, N + IF( K.GE.3 ) THEN + TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 ) + ELSE IF( K.EQ.2 ) THEN + TEMP = Y( K ) - B( K-1 )*Y( K-1 ) + ELSE + TEMP = Y( K ) + END IF + AK = A( K ) + PERT = SIGN( TOL, AK ) + 70 CONTINUE + ABSAK = ABS( AK ) + IF( ABSAK.LT.ONE ) THEN + IF( ABSAK.LT.SFMIN ) THEN + IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) + $ THEN + AK = AK + PERT + PERT = 2*PERT + GO TO 70 + ELSE + TEMP = TEMP*BIGNUM + AK = AK*BIGNUM + END IF + ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN + AK = AK + PERT + PERT = 2*PERT + GO TO 70 + END IF + END IF + Y( K ) = TEMP / AK + 80 CONTINUE + END IF +* + DO 90 K = N, 2, -1 + IF( IN( K-1 ).EQ.0 ) THEN + Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K ) + ELSE + TEMP = Y( K-1 ) + Y( K-1 ) = Y( K ) + Y( K ) = TEMP - C( K-1 )*Y( K ) + END IF + 90 CONTINUE + END IF +* +* End of DLAGTS +* + END diff --git a/math/lapack/src/main/fortran/dlagv2.f b/math/lapack/src/main/fortran/dlagv2.f new file mode 100644 index 0000000000..16c608204a --- /dev/null +++ b/math/lapack/src/main/fortran/dlagv2.f @@ -0,0 +1,374 @@ +*> \brief \b DLAGV2 computes the Generalized Schur factorization of a real 2-by-2 matrix pencil (A,B) where B is upper triangular. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAGV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, +* CSR, SNR ) +* +* .. 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 ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> THe leading dimension of the array A. LDA >= 2. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> THe leading dimension of the array B. LDB >= 2. +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is DOUBLE PRECISION array, dimension (2) +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is DOUBLE PRECISION array, dimension (2) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is 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. +*> \endverbatim +*> +*> \param[out] CSL +*> \verbatim +*> CSL is DOUBLE PRECISION +*> The cosine of the left rotation matrix. +*> \endverbatim +*> +*> \param[out] SNL +*> \verbatim +*> SNL is DOUBLE PRECISION +*> The sine of the left rotation matrix. +*> \endverbatim +*> +*> \param[out] CSR +*> \verbatim +*> CSR is DOUBLE PRECISION +*> The cosine of the right rotation matrix. +*> \endverbatim +*> +*> \param[out] SNR +*> \verbatim +*> SNR is DOUBLE PRECISION +*> The sine of the right rotation matrix. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA +* +* ===================================================================== + SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, + $ CSR, SNR ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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 ) +* .. +* +* ===================================================================== +* +* .. 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 + WI = 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 + WI = 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 + WI = 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**T 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/math/lapack/src/main/fortran/dlahqr.f b/math/lapack/src/main/fortran/dlahqr.f new file mode 100644 index 0000000000..f7365d21ee --- /dev/null +++ b/math/lapack/src/main/fortran/dlahqr.f @@ -0,0 +1,613 @@ +*> \brief \b DLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAHQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, +* ILOZ, IHIZ, Z, LDZ, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> = .TRUE. : the full Schur form T is required; +*> = .FALSE.: only eigenvalues are required. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> = .TRUE. : the matrix of Schur vectors Z is required; +*> = .FALSE.: Schur vectors are not required. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is 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. +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is 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. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the array H. LDH >= max(1,N). +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] WI +*> \verbatim +*> WI is 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). +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. +*> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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.) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) +* .. +* +* ========================================================= +* +* .. Parameters .. + 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, ITMAX, 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 +* +* ITMAX is the total number of QR iterations allowed. +* + ITMAX = 30 * MAX( 10, NH ) +* +* 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 ) THEN +* +* Exceptional shift. +* + S = ABS( H( L+1, L ) ) + ABS( H( L+2, L+1 ) ) + H11 = DAT1*S + H( L, L ) + H12 = DAT2*S + H21 = S + H22 = H11 + ELSE IF( ITS.EQ.20 ) THEN +* +* Exceptional shift. +* + S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) + H11 = DAT1*S + H( I, I ) + H12 = DAT2*S + H21 = S + 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 +* ==== Use the following instead of +* . H( K, K-1 ) = -H( K, K-1 ) to +* . avoid a bug when v(2) and v(3) +* . underflow. ==== + H( K, K-1 ) = H( K, K-1 )*( ONE-T1 ) + END IF + V2 = V( 2 ) + T2 = T1*V2 + 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/math/lapack/src/main/fortran/dlahr2.f b/math/lapack/src/main/fortran/dlahr2.f new file mode 100644 index 0000000000..beb9795bea --- /dev/null +++ b/math/lapack/src/main/fortran/dlahr2.f @@ -0,0 +1,326 @@ +*> \brief \b DLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAHR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) +* +* .. Scalar Arguments .. +* INTEGER K, LDA, LDT, LDY, N, NB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), +* $ Y( LDY, NB ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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**T * A * Q. The routine returns the matrices V and T which determine +*> Q as a block reflector I - V*T*V**T, and also the matrix Y = A * V * T. +*> +*> This is an auxiliary routine called by DGEHRD. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The offset for the reduction. Elements below the k-th +*> subdiagonal in the first NB columns are reduced to zero. +*> K < N. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The number of columns to be reduced. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (NB) +*> The scalar factors of the elementary reflectors. See Further +*> Details. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,NB) +*> The upper triangular matrix T. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension (LDY,NB) +*> The n-by-nb matrix Y. +*> \endverbatim +*> +*> \param[in] LDY +*> \verbatim +*> LDY is INTEGER +*> The leading dimension of the array Y. LDY >= N. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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**T +*> +*> 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**T) * (A - Y*V**T). +*> +*> 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 subroutine 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-3.0's DLAHRD routine. (This +*> subroutine is not backward compatible with LAPACK-3.0's DLAHRD.) +*> \endverbatim +* +*> \par References: +* ================ +*> +*> Gregorio Quintana-Orti and Robert van de Geijn, "Improving the +*> performance of reduction to Hessenberg form," ACM Transactions on +*> Mathematical Software, 32(2):180-194, June 2006. +*> +* ===================================================================== + SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER K, LDA, LDT, LDY, N, NB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), + $ Y( LDY, NB ) +* .. +* +* ===================================================================== +* +* .. 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**T +* + 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**T * V**T 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**T * 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**T * 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**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/math/lapack/src/main/fortran/dlaic1.f b/math/lapack/src/main/fortran/dlaic1.f new file mode 100644 index 0000000000..e9dc0835ef --- /dev/null +++ b/math/lapack/src/main/fortran/dlaic1.f @@ -0,0 +1,367 @@ +*> \brief \b DLAIC1 applies one step of incremental condition estimation. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAIC1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) +* +* .. Scalar Arguments .. +* INTEGER J, JOB +* DOUBLE PRECISION C, GAMMA, S, SEST, SESTPR +* .. +* .. Array Arguments .. +* DOUBLE PRECISION W( J ), X( J ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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**T 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]**T and sestpr**2 is an eigenpair of the system +*> +*> diag(sest*sest, 0) + [alpha gamma] * [ alpha ] +*> [ gamma ] +*> +*> where alpha = x**T*w. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is INTEGER +*> = 1: an estimate for the largest singular value is computed. +*> = 2: an estimate for the smallest singular value is computed. +*> \endverbatim +*> +*> \param[in] J +*> \verbatim +*> J is INTEGER +*> Length of X and W +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (J) +*> The j-vector x. +*> \endverbatim +*> +*> \param[in] SEST +*> \verbatim +*> SEST is DOUBLE PRECISION +*> Estimated singular value of j by j matrix L +*> \endverbatim +*> +*> \param[in] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (J) +*> The j-vector w. +*> \endverbatim +*> +*> \param[in] GAMMA +*> \verbatim +*> GAMMA is DOUBLE PRECISION +*> The diagonal element gamma. +*> \endverbatim +*> +*> \param[out] SESTPR +*> \verbatim +*> SESTPR is DOUBLE PRECISION +*> Estimated singular value of (j+1) by (j+1) matrix Lhat. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION +*> Sine needed in forming xhat. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION +*> Cosine needed in forming xhat. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER J, JOB + DOUBLE PRECISION C, GAMMA, S, SEST, SESTPR +* .. +* .. Array Arguments .. + DOUBLE PRECISION W( J ), X( J ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlaisnan.f b/math/lapack/src/main/fortran/dlaisnan.f new file mode 100644 index 0000000000..4b5ebb4f54 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaisnan.f @@ -0,0 +1,91 @@ +*> \brief \b DLAISNAN tests input for NaN by comparing two arguments for inequality. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAISNAN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION DIN1, DIN2 +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This routine is not for general use. It exists solely to avoid +*> over-optimization in DISNAN. +*> +*> DLAISNAN checks for NaNs by comparing its two arguments for +*> inequality. NaN is the only floating-point value where NaN != NaN +*> returns .TRUE. To check for NaNs, pass the same variable as both +*> arguments. +*> +*> A compiler must assume that the two arguments are +*> not the same variable, and the test will not be optimized away. +*> Interprocedural or whole-program optimization may delete this +*> test. The ISNAN functions will be replaced by the correct +*> Fortran 03 intrinsic once the intrinsic is widely available. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DIN1 +*> \verbatim +*> DIN1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] DIN2 +*> \verbatim +*> DIN2 is DOUBLE PRECISION +*> Two numbers to compare for inequality. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DIN1, DIN2 +* .. +* +* ===================================================================== +* +* .. Executable Statements .. + DLAISNAN = (DIN1.NE.DIN2) + RETURN + END diff --git a/math/lapack/src/main/fortran/dlaln2.f b/math/lapack/src/main/fortran/dlaln2.f new file mode 100644 index 0000000000..a094b737bd --- /dev/null +++ b/math/lapack/src/main/fortran/dlaln2.f @@ -0,0 +1,611 @@ +*> \brief \b DLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLALN2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, +* LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) +* +* .. 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLALN2 solves a system of the form (ca A - w D ) X = s B +*> or (ca A**T - w D) X = s B with possible scaling ("s") and +*> perturbation of A. (A**T 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.) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] LTRANS +*> \verbatim +*> LTRANS is LOGICAL +*> =.TRUE.: A-transpose will be used. +*> =.FALSE.: A will be used (not transposed.) +*> \endverbatim +*> +*> \param[in] NA +*> \verbatim +*> NA is INTEGER +*> The size of the matrix A. It may (only) be 1 or 2. +*> \endverbatim +*> +*> \param[in] NW +*> \verbatim +*> NW is INTEGER +*> 1 if "w" is real, 2 if "w" is complex. It may only be 1 +*> or 2. +*> \endverbatim +*> +*> \param[in] SMIN +*> \verbatim +*> SMIN is 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.) +*> \endverbatim +*> +*> \param[in] CA +*> \verbatim +*> CA is DOUBLE PRECISION +*> The coefficient c, which A is multiplied by. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,NA) +*> The NA x NA matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at least NA. +*> \endverbatim +*> +*> \param[in] D1 +*> \verbatim +*> D1 is DOUBLE PRECISION +*> The 1,1 element in the diagonal matrix D. +*> \endverbatim +*> +*> \param[in] D2 +*> \verbatim +*> D2 is DOUBLE PRECISION +*> The 2,2 element in the diagonal matrix D. Not used if NA=1. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. It must be at least NA. +*> \endverbatim +*> +*> \param[in] WR +*> \verbatim +*> WR is DOUBLE PRECISION +*> The real part of the scalar "w". +*> \endverbatim +*> +*> \param[in] WI +*> \verbatim +*> WI is DOUBLE PRECISION +*> The imaginary part of the scalar "w". Not used if NW=1. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is 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. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of X. It must be at least NA. +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is 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. +*> \endverbatim +*> +*> \param[out] XNORM +*> \verbatim +*> XNORM is DOUBLE PRECISION +*> The infinity-norm of X, when X is regarded as an NA x NW +*> real matrix. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + 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.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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, * ) +* .. +* +* ===================================================================== +* +* .. 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**T - 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/math/lapack/src/main/fortran/dlals0.f b/math/lapack/src/main/fortran/dlals0.f new file mode 100644 index 0000000000..d4cff166d6 --- /dev/null +++ b/math/lapack/src/main/fortran/dlals0.f @@ -0,0 +1,499 @@ +*> \brief \b DLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer SVD approach. Used by sgelsd. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLALS0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, +* PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, +* POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, +* $ LDGNUM, NL, NR, NRHS, SQRE +* DOUBLE PRECISION C, S +* .. +* .. Array Arguments .. +* INTEGER GIVCOL( LDGCOL, * ), PERM( * ) +* DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), DIFL( * ), +* $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ), +* $ POLES( LDGNUM, * ), WORK( * ), Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLALS0 applies back the multiplying factors of either the left or the +*> right singular vector matrix of a diagonal matrix appended by a row +*> to the right hand side matrix B in solving the least squares problem +*> using the divide-and-conquer SVD approach. +*> +*> For the left singular vector matrix, three types of orthogonal +*> matrices are involved: +*> +*> (1L) Givens rotations: the number of such rotations is GIVPTR; the +*> pairs of columns/rows they were applied to are stored in GIVCOL; +*> and the C- and S-values of these rotations are stored in GIVNUM. +*> +*> (2L) Permutation. The (NL+1)-st row of B is to be moved to the first +*> row, and for J=2:N, PERM(J)-th row of B is to be moved to the +*> J-th row. +*> +*> (3L) The left singular vector matrix of the remaining matrix. +*> +*> For the right singular vector matrix, four types of orthogonal +*> matrices are involved: +*> +*> (1R) The right singular vector matrix of the remaining matrix. +*> +*> (2R) If SQRE = 1, one extra Givens rotation to generate the right +*> null space. +*> +*> (3R) The inverse transformation of (2L). +*> +*> (4R) The inverse transformation of (1L). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ICOMPQ +*> \verbatim +*> ICOMPQ is INTEGER +*> Specifies whether singular vectors are to be computed in +*> factored form: +*> = 0: Left singular vector matrix. +*> = 1: Right singular vector matrix. +*> \endverbatim +*> +*> \param[in] NL +*> \verbatim +*> NL is INTEGER +*> The row dimension of the upper block. NL >= 1. +*> \endverbatim +*> +*> \param[in] NR +*> \verbatim +*> NR is INTEGER +*> The row dimension of the lower block. NR >= 1. +*> \endverbatim +*> +*> \param[in] SQRE +*> \verbatim +*> SQRE is INTEGER +*> = 0: the lower block is an NR-by-NR square matrix. +*> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. +*> +*> The bidiagonal matrix has row dimension N = NL + NR + 1, +*> and column dimension M = N + SQRE. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of columns of B and BX. NRHS must be at least 1. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension ( LDB, NRHS ) +*> On input, B contains the right hand sides of the least +*> squares problem in rows 1 through M. On output, B contains +*> the solution X in rows 1 through N. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. LDB must be at least +*> max(1,MAX( M, N ) ). +*> \endverbatim +*> +*> \param[out] BX +*> \verbatim +*> BX is DOUBLE PRECISION array, dimension ( LDBX, NRHS ) +*> \endverbatim +*> +*> \param[in] LDBX +*> \verbatim +*> LDBX is INTEGER +*> The leading dimension of BX. +*> \endverbatim +*> +*> \param[in] PERM +*> \verbatim +*> PERM is INTEGER array, dimension ( N ) +*> The permutations (from deflation and sorting) applied +*> to the two blocks. +*> \endverbatim +*> +*> \param[in] GIVPTR +*> \verbatim +*> GIVPTR is INTEGER +*> The number of Givens rotations which took place in this +*> subproblem. +*> \endverbatim +*> +*> \param[in] GIVCOL +*> \verbatim +*> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) +*> Each pair of numbers indicates a pair of rows/columns +*> involved in a Givens rotation. +*> \endverbatim +*> +*> \param[in] LDGCOL +*> \verbatim +*> LDGCOL is INTEGER +*> The leading dimension of GIVCOL, must be at least N. +*> \endverbatim +*> +*> \param[in] GIVNUM +*> \verbatim +*> GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) +*> Each number indicates the C or S value used in the +*> corresponding Givens rotation. +*> \endverbatim +*> +*> \param[in] LDGNUM +*> \verbatim +*> LDGNUM is INTEGER +*> The leading dimension of arrays DIFR, POLES and +*> GIVNUM, must be at least K. +*> \endverbatim +*> +*> \param[in] POLES +*> \verbatim +*> POLES is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) +*> On entry, POLES(1:K, 1) contains the new singular +*> values obtained from solving the secular equation, and +*> POLES(1:K, 2) is an array containing the poles in the secular +*> equation. +*> \endverbatim +*> +*> \param[in] DIFL +*> \verbatim +*> DIFL is DOUBLE PRECISION array, dimension ( K ). +*> On entry, DIFL(I) is the distance between I-th updated +*> (undeflated) singular value and the I-th (undeflated) old +*> singular value. +*> \endverbatim +*> +*> \param[in] DIFR +*> \verbatim +*> DIFR is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ). +*> On entry, DIFR(I, 1) contains the distances between I-th +*> updated (undeflated) singular value and the I+1-th +*> (undeflated) old singular value. And DIFR(I, 2) is the +*> normalizing factor for the I-th right singular vector. +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( K ) +*> Contain the components of the deflation-adjusted updating row +*> vector. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> Contains the dimension of the non-deflated matrix, +*> This is the order of the related secular equation. 1 <= K <=N. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION +*> C contains garbage if SQRE =0 and the C-value of a Givens +*> rotation related to the right null space if SQRE = 1. +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is DOUBLE PRECISION +*> S contains garbage if SQRE =0 and the S-value of a Givens +*> rotation related to the right null space if SQRE = 1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension ( K ) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Ren-Cang Li, Computer Science Division, University of +*> California at Berkeley, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +* +* ===================================================================== + SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, + $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, + $ POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, + $ LDGNUM, NL, NR, NRHS, SQRE + DOUBLE PRECISION C, S +* .. +* .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), PERM( * ) + DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), DIFL( * ), + $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ), + $ POLES( LDGNUM, * ), WORK( * ), Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO, NEGONE + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, M, N, NLP1 + DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DROT, DSCAL, + $ XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3, DNRM2 + EXTERNAL DLAMC3, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + N = NL + NR + 1 +* + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( NL.LT.1 ) THEN + INFO = -2 + ELSE IF( NR.LT.1 ) THEN + INFO = -3 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -4 + ELSE IF( NRHS.LT.1 ) THEN + INFO = -5 + ELSE IF( LDB.LT.N ) THEN + INFO = -7 + ELSE IF( LDBX.LT.N ) THEN + INFO = -9 + ELSE IF( GIVPTR.LT.0 ) THEN + INFO = -11 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -13 + ELSE IF( LDGNUM.LT.N ) THEN + INFO = -15 + ELSE IF( K.LT.1 ) THEN + INFO = -20 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLALS0', -INFO ) + RETURN + END IF +* + M = N + SQRE + NLP1 = NL + 1 +* + IF( ICOMPQ.EQ.0 ) THEN +* +* Apply back orthogonal transformations from the left. +* +* Step (1L): apply back the Givens rotations performed. +* + DO 10 I = 1, GIVPTR + CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB, + $ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ), + $ GIVNUM( I, 1 ) ) + 10 CONTINUE +* +* Step (2L): permute rows of B. +* + CALL DCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX ) + DO 20 I = 2, N + CALL DCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX ) + 20 CONTINUE +* +* Step (3L): apply the inverse of the left singular vector +* matrix to BX. +* + IF( K.EQ.1 ) THEN + CALL DCOPY( NRHS, BX, LDBX, B, LDB ) + IF( Z( 1 ).LT.ZERO ) THEN + CALL DSCAL( NRHS, NEGONE, B, LDB ) + END IF + ELSE + DO 50 J = 1, K + DIFLJ = DIFL( J ) + DJ = POLES( J, 1 ) + DSIGJ = -POLES( J, 2 ) + IF( J.LT.K ) THEN + DIFRJ = -DIFR( J, 1 ) + DSIGJP = -POLES( J+1, 2 ) + END IF + IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) ) + $ THEN + WORK( J ) = ZERO + ELSE + WORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ / + $ ( POLES( J, 2 )+DJ ) + END IF + DO 30 I = 1, J - 1 + IF( ( Z( I ).EQ.ZERO ) .OR. + $ ( POLES( I, 2 ).EQ.ZERO ) ) THEN + WORK( I ) = ZERO + ELSE + WORK( I ) = POLES( I, 2 )*Z( I ) / + $ ( DLAMC3( POLES( I, 2 ), DSIGJ )- + $ DIFLJ ) / ( POLES( I, 2 )+DJ ) + END IF + 30 CONTINUE + DO 40 I = J + 1, K + IF( ( Z( I ).EQ.ZERO ) .OR. + $ ( POLES( I, 2 ).EQ.ZERO ) ) THEN + WORK( I ) = ZERO + ELSE + WORK( I ) = POLES( I, 2 )*Z( I ) / + $ ( DLAMC3( POLES( I, 2 ), DSIGJP )+ + $ DIFRJ ) / ( POLES( I, 2 )+DJ ) + END IF + 40 CONTINUE + WORK( 1 ) = NEGONE + TEMP = DNRM2( K, WORK, 1 ) + CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO, + $ B( J, 1 ), LDB ) + CALL DLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ), + $ LDB, INFO ) + 50 CONTINUE + END IF +* +* Move the deflated rows of BX to B also. +* + IF( K.LT.MAX( M, N ) ) + $ CALL DLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX, + $ B( K+1, 1 ), LDB ) + ELSE +* +* Apply back the right orthogonal transformations. +* +* Step (1R): apply back the new right singular vector matrix +* to B. +* + IF( K.EQ.1 ) THEN + CALL DCOPY( NRHS, B, LDB, BX, LDBX ) + ELSE + DO 80 J = 1, K + DSIGJ = POLES( J, 2 ) + IF( Z( J ).EQ.ZERO ) THEN + WORK( J ) = ZERO + ELSE + WORK( J ) = -Z( J ) / DIFL( J ) / + $ ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 ) + END IF + DO 60 I = 1, J - 1 + IF( Z( J ).EQ.ZERO ) THEN + WORK( I ) = ZERO + ELSE + WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I+1, + $ 2 ) )-DIFR( I, 1 ) ) / + $ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 ) + END IF + 60 CONTINUE + DO 70 I = J + 1, K + IF( Z( J ).EQ.ZERO ) THEN + WORK( I ) = ZERO + ELSE + WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I, + $ 2 ) )-DIFL( I ) ) / + $ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 ) + END IF + 70 CONTINUE + CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO, + $ BX( J, 1 ), LDBX ) + 80 CONTINUE + END IF +* +* Step (2R): if SQRE = 1, apply back the rotation that is +* related to the right null space of the subproblem. +* + IF( SQRE.EQ.1 ) THEN + CALL DCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX ) + CALL DROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S ) + END IF + IF( K.LT.MAX( M, N ) ) + $ CALL DLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ), + $ LDBX ) +* +* Step (3R): permute rows of B. +* + CALL DCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB ) + IF( SQRE.EQ.1 ) THEN + CALL DCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB ) + END IF + DO 90 I = 2, N + CALL DCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB ) + 90 CONTINUE +* +* Step (4R): apply back the Givens rotations performed. +* + DO 100 I = GIVPTR, 1, -1 + CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB, + $ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ), + $ -GIVNUM( I, 1 ) ) + 100 CONTINUE + END IF +* + RETURN +* +* End of DLALS0 +* + END diff --git a/math/lapack/src/main/fortran/dlalsa.f b/math/lapack/src/main/fortran/dlalsa.f new file mode 100644 index 0000000000..4aef66c95c --- /dev/null +++ b/math/lapack/src/main/fortran/dlalsa.f @@ -0,0 +1,495 @@ +*> \brief \b DLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLALSA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, +* LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, +* GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, +* IWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, +* $ SMLSIZ +* .. +* .. Array Arguments .. +* INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), +* $ K( * ), PERM( LDGCOL, * ) +* DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), C( * ), +* $ DIFL( LDU, * ), DIFR( LDU, * ), +* $ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ), +* $ U( LDU, * ), VT( LDU, * ), WORK( * ), +* $ Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLALSA is an itermediate step in solving the least squares problem +*> by computing the SVD of the coefficient matrix in compact form (The +*> singular vectors are computed as products of simple orthorgonal +*> matrices.). +*> +*> If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector +*> matrix of an upper bidiagonal matrix to the right hand side; and if +*> ICOMPQ = 1, DLALSA applies the right singular vector matrix to the +*> right hand side. The singular vector matrices were generated in +*> compact form by DLALSA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ICOMPQ +*> \verbatim +*> ICOMPQ is INTEGER +*> Specifies whether the left or the right singular vector +*> matrix is involved. +*> = 0: Left singular vector matrix +*> = 1: Right singular vector matrix +*> \endverbatim +*> +*> \param[in] SMLSIZ +*> \verbatim +*> SMLSIZ is INTEGER +*> The maximum size of the subproblems at the bottom of the +*> computation tree. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The row and column dimensions of the upper bidiagonal matrix. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of columns of B and BX. NRHS must be at least 1. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension ( LDB, NRHS ) +*> On input, B contains the right hand sides of the least +*> squares problem in rows 1 through M. +*> On output, B contains the solution X in rows 1 through N. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B in the calling subprogram. +*> LDB must be at least max(1,MAX( M, N ) ). +*> \endverbatim +*> +*> \param[out] BX +*> \verbatim +*> BX is DOUBLE PRECISION array, dimension ( LDBX, NRHS ) +*> On exit, the result of applying the left or right singular +*> vector matrix to B. +*> \endverbatim +*> +*> \param[in] LDBX +*> \verbatim +*> LDBX is INTEGER +*> The leading dimension of BX. +*> \endverbatim +*> +*> \param[in] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ). +*> On entry, U contains the left singular vector matrices of all +*> subproblems at the bottom level. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER, LDU = > N. +*> The leading dimension of arrays U, VT, DIFL, DIFR, +*> POLES, GIVNUM, and Z. +*> \endverbatim +*> +*> \param[in] VT +*> \verbatim +*> VT is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ). +*> On entry, VT**T contains the right singular vector matrices of +*> all subproblems at the bottom level. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER array, dimension ( N ). +*> \endverbatim +*> +*> \param[in] DIFL +*> \verbatim +*> DIFL is DOUBLE PRECISION array, dimension ( LDU, NLVL ). +*> where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. +*> \endverbatim +*> +*> \param[in] DIFR +*> \verbatim +*> DIFR is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). +*> On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record +*> distances between singular values on the I-th level and +*> singular values on the (I -1)-th level, and DIFR(*, 2 * I) +*> record the normalizing factors of the right singular vectors +*> matrices of subproblems on I-th level. +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( LDU, NLVL ). +*> On entry, Z(1, I) contains the components of the deflation- +*> adjusted updating row vector for subproblems on the I-th +*> level. +*> \endverbatim +*> +*> \param[in] POLES +*> \verbatim +*> POLES is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). +*> On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old +*> singular values involved in the secular equations on the I-th +*> level. +*> \endverbatim +*> +*> \param[in] GIVPTR +*> \verbatim +*> GIVPTR is INTEGER array, dimension ( N ). +*> On entry, GIVPTR( I ) records the number of Givens +*> rotations performed on the I-th problem on the computation +*> tree. +*> \endverbatim +*> +*> \param[in] GIVCOL +*> \verbatim +*> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 * NLVL ). +*> On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the +*> locations of Givens rotations performed on the I-th level on +*> the computation tree. +*> \endverbatim +*> +*> \param[in] LDGCOL +*> \verbatim +*> LDGCOL is INTEGER, LDGCOL = > N. +*> The leading dimension of arrays GIVCOL and PERM. +*> \endverbatim +*> +*> \param[in] PERM +*> \verbatim +*> PERM is INTEGER array, dimension ( LDGCOL, NLVL ). +*> On entry, PERM(*, I) records permutations done on the I-th +*> level of the computation tree. +*> \endverbatim +*> +*> \param[in] GIVNUM +*> \verbatim +*> GIVNUM is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). +*> On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- +*> values of Givens rotations performed on the I-th level on the +*> computation tree. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension ( N ). +*> On entry, if the I-th subproblem is not square, +*> C( I ) contains the C-value of a Givens rotation related to +*> the right null space of the I-th subproblem. +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension ( N ). +*> On entry, if the I-th subproblem is not square, +*> S( I ) contains the S-value of a Givens rotation related to +*> the right null space of the I-th subproblem. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array. +*> The dimension must be at least N. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array. +*> The dimension must be at least 3 * N +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Ren-Cang Li, Computer Science Division, University of +*> California at Berkeley, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +* +* ===================================================================== + SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, + $ LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, + $ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, + $ IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, + $ SMLSIZ +* .. +* .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), + $ K( * ), PERM( LDGCOL, * ) + DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), C( * ), + $ DIFL( LDU, * ), DIFR( LDU, * ), + $ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ), + $ U( LDU, * ), VT( LDU, * ), WORK( * ), + $ Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I, I1, IC, IM1, INODE, J, LF, LL, LVL, LVL2, + $ ND, NDB1, NDIML, NDIMR, NL, NLF, NLP1, NLVL, + $ NR, NRF, NRP1, SQRE +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLALS0, DLASDT, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( SMLSIZ.LT.3 ) THEN + INFO = -2 + ELSE IF( N.LT.SMLSIZ ) THEN + INFO = -3 + ELSE IF( NRHS.LT.1 ) THEN + INFO = -4 + ELSE IF( LDB.LT.N ) THEN + INFO = -6 + ELSE IF( LDBX.LT.N ) THEN + INFO = -8 + ELSE IF( LDU.LT.N ) THEN + INFO = -10 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -19 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLALSA', -INFO ) + RETURN + END IF +* +* Book-keeping and setting up the computation tree. +* + INODE = 1 + NDIML = INODE + N + NDIMR = NDIML + N +* + CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), + $ IWORK( NDIMR ), SMLSIZ ) +* +* The following code applies back the left singular vector factors. +* For applying back the right singular vector factors, go to 50. +* + IF( ICOMPQ.EQ.1 ) THEN + GO TO 50 + END IF +* +* The nodes on the bottom level of the tree were solved +* by DLASDQ. The corresponding left and right singular vector +* matrices are in explicit form. First apply back the left +* singular vector matrices. +* + NDB1 = ( ND+1 ) / 2 + DO 10 I = NDB1, ND +* +* IC : center row of each node +* NL : number of rows of left subproblem +* NR : number of rows of right subproblem +* NLF: starting row of the left subproblem +* NRF: starting row of the right subproblem +* + I1 = I - 1 + IC = IWORK( INODE+I1 ) + NL = IWORK( NDIML+I1 ) + NR = IWORK( NDIMR+I1 ) + NLF = IC - NL + NRF = IC + 1 + CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU, + $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) + CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU, + $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) + 10 CONTINUE +* +* Next copy the rows of B that correspond to unchanged rows +* in the bidiagonal matrix to BX. +* + DO 20 I = 1, ND + IC = IWORK( INODE+I-1 ) + CALL DCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX ) + 20 CONTINUE +* +* Finally go through the left singular vector matrices of all +* the other subproblems bottom-up on the tree. +* + J = 2**NLVL + SQRE = 0 +* + DO 40 LVL = NLVL, 1, -1 + LVL2 = 2*LVL - 1 +* +* find the first node LF and last node LL on +* the current level LVL +* + IF( LVL.EQ.1 ) THEN + LF = 1 + LL = 1 + ELSE + LF = 2**( LVL-1 ) + LL = 2*LF - 1 + END IF + DO 30 I = LF, LL + IM1 = I - 1 + IC = IWORK( INODE+IM1 ) + NL = IWORK( NDIML+IM1 ) + NR = IWORK( NDIMR+IM1 ) + NLF = IC - NL + NRF = IC + 1 + J = J - 1 + CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX, + $ B( NLF, 1 ), LDB, PERM( NLF, LVL ), + $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, + $ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ), + $ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ), + $ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK, + $ INFO ) + 30 CONTINUE + 40 CONTINUE + GO TO 90 +* +* ICOMPQ = 1: applying back the right singular vector factors. +* + 50 CONTINUE +* +* First now go through the right singular vector matrices of all +* the tree nodes top-down. +* + J = 0 + DO 70 LVL = 1, NLVL + LVL2 = 2*LVL - 1 +* +* Find the first node LF and last node LL on +* the current level LVL. +* + IF( LVL.EQ.1 ) THEN + LF = 1 + LL = 1 + ELSE + LF = 2**( LVL-1 ) + LL = 2*LF - 1 + END IF + DO 60 I = LL, LF, -1 + IM1 = I - 1 + IC = IWORK( INODE+IM1 ) + NL = IWORK( NDIML+IM1 ) + NR = IWORK( NDIMR+IM1 ) + NLF = IC - NL + NRF = IC + 1 + IF( I.EQ.LL ) THEN + SQRE = 0 + ELSE + SQRE = 1 + END IF + J = J + 1 + CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB, + $ BX( NLF, 1 ), LDBX, PERM( NLF, LVL ), + $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, + $ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ), + $ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ), + $ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK, + $ INFO ) + 60 CONTINUE + 70 CONTINUE +* +* The nodes on the bottom level of the tree were solved +* by DLASDQ. The corresponding right singular vector +* matrices are in explicit form. Apply them back. +* + NDB1 = ( ND+1 ) / 2 + DO 80 I = NDB1, ND + I1 = I - 1 + IC = IWORK( INODE+I1 ) + NL = IWORK( NDIML+I1 ) + NR = IWORK( NDIMR+I1 ) + NLP1 = NL + 1 + IF( I.EQ.ND ) THEN + NRP1 = NR + ELSE + NRP1 = NR + 1 + END IF + NLF = IC - NL + NRF = IC + 1 + CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU, + $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) + CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU, + $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) + 80 CONTINUE +* + 90 CONTINUE +* + RETURN +* +* End of DLALSA +* + END diff --git a/math/lapack/src/main/fortran/dlalsd.f b/math/lapack/src/main/fortran/dlalsd.f new file mode 100644 index 0000000000..510e0455a6 --- /dev/null +++ b/math/lapack/src/main/fortran/dlalsd.f @@ -0,0 +1,523 @@ +*> \brief \b DLALSD uses the singular value decomposition of A to solve the least squares problem. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLALSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, +* RANK, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLALSD uses the singular value decomposition of A to solve the least +*> squares problem of finding X to minimize the Euclidean norm of each +*> column of A*X-B, where A is N-by-N upper bidiagonal, and X and B +*> are N-by-NRHS. The solution X overwrites B. +*> +*> The singular values of A smaller than RCOND times the largest +*> singular value are treated as zero in solving the least squares +*> problem; in this case a minimum norm solution is returned. +*> The actual singular values are returned in D in ascending order. +*> +*> This code makes very mild assumptions about floating point +*> arithmetic. It will work on machines with a guard digit in +*> add/subtract, or on those binary machines without guard digits +*> which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. +*> It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': D and E define an upper bidiagonal matrix. +*> = 'L': D and E define a lower bidiagonal matrix. +*> \endverbatim +*> +*> \param[in] SMLSIZ +*> \verbatim +*> SMLSIZ is INTEGER +*> The maximum size of the subproblems at the bottom of the +*> computation tree. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The dimension of the bidiagonal matrix. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of columns of B. NRHS must be at least 1. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry D contains the main diagonal of the bidiagonal +*> matrix. On exit, if INFO = 0, D contains its singular values. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> Contains the super-diagonal entries of the bidiagonal matrix. +*> On exit, E has been destroyed. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On input, B contains the right hand sides of the least +*> squares problem. On output, B contains the solution X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B in the calling subprogram. +*> LDB must be at least max(1,N). +*> \endverbatim +*> +*> \param[in] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The singular values of A less than or equal to RCOND times +*> the largest singular value are treated as zero in solving +*> the least squares problem. If RCOND is negative, +*> machine precision is used instead. +*> For example, if diag(S)*X=B were the least squares problem, +*> where diag(S) is a diagonal matrix of singular values, the +*> solution would be X(i) = B(i) / S(i) if S(i) is greater than +*> RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to +*> RCOND*max(S). +*> \endverbatim +*> +*> \param[out] RANK +*> \verbatim +*> RANK is INTEGER +*> The number of singular values of A greater than RCOND times +*> the largest singular value. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension at least +*> (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), +*> where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1). +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension at least +*> (3*N*NLVL + 11*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: The algorithm failed to compute a singular value while +*> working on the submatrix lying in rows and columns +*> INFO/(N+1) through MOD(INFO,N+1). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Ren-Cang Li, Computer Science Division, University of +*> California at Berkeley, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +* +* ===================================================================== + SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, + $ RANK, WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +* .. +* .. Local Scalars .. + INTEGER BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM, + $ GIVPTR, I, ICMPQ1, ICMPQ2, IWK, J, K, NLVL, + $ NM1, NSIZE, NSUB, NWORK, PERM, POLES, S, SIZEI, + $ SMLSZP, SQRE, ST, ST1, U, VT, Z + DOUBLE PRECISION CS, EPS, ORGNRM, R, RCND, SN, TOL +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLANST + EXTERNAL IDAMAX, DLAMCH, DLANST +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLACPY, DLALSA, DLARTG, DLASCL, + $ DLASDA, DLASDQ, DLASET, DLASRT, DROT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG, SIGN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.1 ) THEN + INFO = -4 + ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLALSD', -INFO ) + RETURN + END IF +* + EPS = DLAMCH( 'Epsilon' ) +* +* Set up the tolerance. +* + IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN + RCND = EPS + ELSE + RCND = RCOND + END IF +* + RANK = 0 +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + RETURN + ELSE IF( N.EQ.1 ) THEN + IF( D( 1 ).EQ.ZERO ) THEN + CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B, LDB ) + ELSE + RANK = 1 + CALL DLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO ) + D( 1 ) = ABS( D( 1 ) ) + END IF + RETURN + END IF +* +* Rotate the matrix if it is lower bidiagonal. +* + IF( UPLO.EQ.'L' ) 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 ) + IF( NRHS.EQ.1 ) THEN + CALL DROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN ) + ELSE + WORK( I*2-1 ) = CS + WORK( I*2 ) = SN + END IF + 10 CONTINUE + IF( NRHS.GT.1 ) THEN + DO 30 I = 1, NRHS + DO 20 J = 1, N - 1 + CS = WORK( J*2-1 ) + SN = WORK( J*2 ) + CALL DROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN ) + 20 CONTINUE + 30 CONTINUE + END IF + END IF +* +* Scale. +* + NM1 = N - 1 + ORGNRM = DLANST( 'M', N, D, E ) + IF( ORGNRM.EQ.ZERO ) THEN + CALL DLASET( 'A', N, NRHS, ZERO, ZERO, B, LDB ) + RETURN + END IF +* + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO ) + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO ) +* +* If N is smaller than the minimum divide size SMLSIZ, then solve +* the problem with another solver. +* + IF( N.LE.SMLSIZ ) THEN + NWORK = 1 + N*N + CALL DLASET( 'A', N, N, ZERO, ONE, WORK, N ) + CALL DLASDQ( 'U', 0, N, N, 0, NRHS, D, E, WORK, N, WORK, N, B, + $ LDB, WORK( NWORK ), INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) ) + DO 40 I = 1, N + IF( D( I ).LE.TOL ) THEN + CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) + ELSE + CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ), + $ LDB, INFO ) + RANK = RANK + 1 + END IF + 40 CONTINUE + CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO, + $ WORK( NWORK ), N ) + CALL DLACPY( 'A', N, NRHS, WORK( NWORK ), N, B, LDB ) +* +* Unscale. +* + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) + CALL DLASRT( 'D', N, D, INFO ) + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO ) +* + RETURN + END IF +* +* Book-keeping and setting up some constants. +* + NLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1 +* + SMLSZP = SMLSIZ + 1 +* + U = 1 + VT = 1 + SMLSIZ*N + DIFL = VT + SMLSZP*N + DIFR = DIFL + NLVL*N + Z = DIFR + NLVL*N*2 + C = Z + NLVL*N + S = C + N + POLES = S + N + GIVNUM = POLES + 2*NLVL*N + BX = GIVNUM + 2*NLVL*N + NWORK = BX + N*NRHS +* + SIZEI = 1 + N + K = SIZEI + N + GIVPTR = K + N + PERM = GIVPTR + N + GIVCOL = PERM + NLVL*N + IWK = GIVCOL + NLVL*N*2 +* + ST = 1 + SQRE = 0 + ICMPQ1 = 1 + ICMPQ2 = 0 + NSUB = 0 +* + DO 50 I = 1, N + IF( ABS( D( I ) ).LT.EPS ) THEN + D( I ) = SIGN( EPS, D( I ) ) + END IF + 50 CONTINUE +* + DO 60 I = 1, NM1 + IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN + NSUB = NSUB + 1 + IWORK( NSUB ) = ST +* +* Subproblem found. First determine its size and then +* apply divide and conquer on it. +* + IF( I.LT.NM1 ) THEN +* +* A subproblem with E(I) small for I < NM1. +* + NSIZE = I - ST + 1 + IWORK( SIZEI+NSUB-1 ) = NSIZE + ELSE IF( ABS( E( I ) ).GE.EPS ) THEN +* +* A subproblem with E(NM1) not too small but I = NM1. +* + NSIZE = N - ST + 1 + IWORK( SIZEI+NSUB-1 ) = NSIZE + ELSE +* +* A subproblem with E(NM1) small. This implies an +* 1-by-1 subproblem at D(N), which is not solved +* explicitly. +* + NSIZE = I - ST + 1 + IWORK( SIZEI+NSUB-1 ) = NSIZE + NSUB = NSUB + 1 + IWORK( NSUB ) = N + IWORK( SIZEI+NSUB-1 ) = 1 + CALL DCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N ) + END IF + ST1 = ST - 1 + IF( NSIZE.EQ.1 ) THEN +* +* This is a 1-by-1 subproblem and is not solved +* explicitly. +* + CALL DCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N ) + ELSE IF( NSIZE.LE.SMLSIZ ) THEN +* +* This is a small subproblem and is solved by DLASDQ. +* + CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE, + $ WORK( VT+ST1 ), N ) + CALL DLASDQ( 'U', 0, NSIZE, NSIZE, 0, NRHS, D( ST ), + $ E( ST ), WORK( VT+ST1 ), N, WORK( NWORK ), + $ N, B( ST, 1 ), LDB, WORK( NWORK ), INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + CALL DLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB, + $ WORK( BX+ST1 ), N ) + ELSE +* +* A large problem. Solve it using divide and conquer. +* + CALL DLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ), + $ E( ST ), WORK( U+ST1 ), N, WORK( VT+ST1 ), + $ IWORK( K+ST1 ), WORK( DIFL+ST1 ), + $ WORK( DIFR+ST1 ), WORK( Z+ST1 ), + $ WORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ), + $ IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ), + $ WORK( GIVNUM+ST1 ), WORK( C+ST1 ), + $ WORK( S+ST1 ), WORK( NWORK ), IWORK( IWK ), + $ INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + BXST = BX + ST1 + CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ), + $ LDB, WORK( BXST ), N, WORK( U+ST1 ), N, + $ WORK( VT+ST1 ), IWORK( K+ST1 ), + $ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ), + $ WORK( Z+ST1 ), WORK( POLES+ST1 ), + $ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N, + $ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ), + $ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ), + $ IWORK( IWK ), INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + END IF + ST = I + 1 + END IF + 60 CONTINUE +* +* Apply the singular values and treat the tiny ones as zero. +* + TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) ) +* + DO 70 I = 1, N +* +* Some of the elements in D can be negative because 1-by-1 +* subproblems were not solved explicitly. +* + IF( ABS( D( I ) ).LE.TOL ) THEN + CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, WORK( BX+I-1 ), N ) + ELSE + RANK = RANK + 1 + CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, + $ WORK( BX+I-1 ), N, INFO ) + END IF + D( I ) = ABS( D( I ) ) + 70 CONTINUE +* +* Now apply back the right singular vectors. +* + ICMPQ2 = 1 + DO 80 I = 1, NSUB + ST = IWORK( I ) + ST1 = ST - 1 + NSIZE = IWORK( SIZEI+I-1 ) + BXST = BX + ST1 + IF( NSIZE.EQ.1 ) THEN + CALL DCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB ) + ELSE IF( NSIZE.LE.SMLSIZ ) THEN + CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE, + $ WORK( VT+ST1 ), N, WORK( BXST ), N, ZERO, + $ B( ST, 1 ), LDB ) + ELSE + CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N, + $ B( ST, 1 ), LDB, WORK( U+ST1 ), N, + $ WORK( VT+ST1 ), IWORK( K+ST1 ), + $ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ), + $ WORK( Z+ST1 ), WORK( POLES+ST1 ), + $ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N, + $ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ), + $ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ), + $ IWORK( IWK ), INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + END IF + 80 CONTINUE +* +* Unscale and sort the singular values. +* + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) + CALL DLASRT( 'D', N, D, INFO ) + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO ) +* + RETURN +* +* End of DLALSD +* + END diff --git a/math/lapack/src/main/fortran/dlamrg.f b/math/lapack/src/main/fortran/dlamrg.f new file mode 100644 index 0000000000..de19508e45 --- /dev/null +++ b/math/lapack/src/main/fortran/dlamrg.f @@ -0,0 +1,171 @@ +*> \brief \b DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single set sorted in ascending order. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAMRG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) +* +* .. Scalar Arguments .. +* INTEGER DTRD1, DTRD2, N1, N2 +* .. +* .. Array Arguments .. +* INTEGER INDEX( * ) +* DOUBLE PRECISION A( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAMRG will create a permutation list which will merge the elements +*> of A (which is composed of two independently sorted sets) into a +*> single set which is sorted in ascending order. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N1 +*> \verbatim +*> N1 is INTEGER +*> \endverbatim +*> +*> \param[in] N2 +*> \verbatim +*> N2 is INTEGER +*> These arguments contain the respective lengths of the two +*> sorted lists to be merged. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (N1+N2) +*> The first N1 elements of A contain a list of numbers which +*> are sorted in either ascending or descending order. Likewise +*> for the final N2 elements. +*> \endverbatim +*> +*> \param[in] DTRD1 +*> \verbatim +*> DTRD1 is INTEGER +*> \endverbatim +*> +*> \param[in] DTRD2 +*> \verbatim +*> DTRD2 is INTEGER +*> These are the strides to be taken through the array A. +*> Allowable strides are 1 and -1. They indicate whether a +*> subset of A is sorted in ascending (DTRDx = 1) or descending +*> (DTRDx = -1) order. +*> \endverbatim +*> +*> \param[out] INDEX +*> \verbatim +*> INDEX is INTEGER array, dimension (N1+N2) +*> On exit this array will contain a permutation such that +*> if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be +*> sorted in ascending order. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER DTRD1, DTRD2, N1, N2 +* .. +* .. Array Arguments .. + INTEGER INDEX( * ) + DOUBLE PRECISION A( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IND1, IND2, N1SV, N2SV +* .. +* .. Executable Statements .. +* + N1SV = N1 + N2SV = N2 + IF( DTRD1.GT.0 ) THEN + IND1 = 1 + ELSE + IND1 = N1 + END IF + IF( DTRD2.GT.0 ) THEN + IND2 = 1 + N1 + ELSE + IND2 = N1 + N2 + END IF + I = 1 +* while ( (N1SV > 0) & (N2SV > 0) ) + 10 CONTINUE + IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN + IF( A( IND1 ).LE.A( IND2 ) ) THEN + INDEX( I ) = IND1 + I = I + 1 + IND1 = IND1 + DTRD1 + N1SV = N1SV - 1 + ELSE + INDEX( I ) = IND2 + I = I + 1 + IND2 = IND2 + DTRD2 + N2SV = N2SV - 1 + END IF + GO TO 10 + END IF +* end while + IF( N1SV.EQ.0 ) THEN + DO 20 N1SV = 1, N2SV + INDEX( I ) = IND2 + I = I + 1 + IND2 = IND2 + DTRD2 + 20 CONTINUE + ELSE +* N2SV .EQ. 0 + DO 30 N2SV = 1, N1SV + INDEX( I ) = IND1 + I = I + 1 + IND1 = IND1 + DTRD1 + 30 CONTINUE + END IF +* + RETURN +* +* End of DLAMRG +* + END diff --git a/math/lapack/src/main/fortran/dlamswlq.f b/math/lapack/src/main/fortran/dlamswlq.f new file mode 100644 index 0000000000..8dc6df8a56 --- /dev/null +++ b/math/lapack/src/main/fortran/dlamswlq.f @@ -0,0 +1,416 @@ +* +* Definition: +* =========== +* +* SUBROUTINE DLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, +* $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. +* DOUBLE A( LDA, * ), WORK( * ), C(LDC, * ), +* $ T( LDT, * ) +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAMQRTS 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 blocked +*> elementary reflectors computed by short wide LQ +*> factorization (DLASWLQ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= M. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> M >= K >= 0; +*> +*> \endverbatim +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The row block size to be used in the blocked QR. +*> M >= MB >= 1 +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> NB > M. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The block size to be used in the blocked QR. +*> MB > M. +*> +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,K) +*> The i-th row must contain the vector which defines the blocked +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DLASWLQ in the first k rows of its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension +*> ( M * Number of blocks(CEIL(N-K/NB-K)), +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See below +*> for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,NB) * MB; +*> if SIDE = 'R', LWORK >= max(1,M) * MB. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A: +*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A +*> . . . +*> +*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GELQT. +*> +*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors +*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, + $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ), C(LDC, * ), + $ T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER I, II, KK, CTR, LW +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL DTPMLQT, DGEMLQT, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.LT.0 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'T' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + IF (LEFT) THEN + LW = N * MB + ELSE + LW = M * MB + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, MB) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN + INFO = -15 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAMSWLQ', -INFO ) + WORK(1) = LW + RETURN + ELSE IF (LQUERY) THEN + WORK(1) = LW + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N,K).EQ.0 ) THEN + RETURN + END IF +* + IF((NB.LE.K).OR.(NB.GE.MAX(M,N,K))) THEN + CALL DGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA, + $ T, LDT, C, LDC, WORK, INFO) + RETURN + END IF +* + IF(LEFT.AND.TRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((M-K),(NB-K)) + CTR = (M-K)/(NB-K) + IF (KK.GT.0) THEN + II=M-KK+1 + CALL DTPMLQT('L','T',KK , N, K, 0, MB, A(1,II), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) + ELSE + II=M+1 + END IF +* + DO I=II-(NB-K),NB+1,-(NB-K) +* +* Multiply Q to the current block of C (1:M,I:I+NB) +* + CTR = CTR - 1 + CALL DTPMLQT('L','T',NB-K , N, K, 0,MB, A(1,I), LDA, + $ T(1, CTR*K+1),LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + + END DO +* +* Multiply Q to the first block of C (1:M,1:NB) +* + CALL DGEMLQT('L','T',NB , N, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (LEFT.AND.NOTRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((M-K),(NB-K)) + II=M-KK+1 + CTR = 1 + CALL DGEMLQT('L','N',NB , N, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=NB+1,II-NB+K,(NB-K) +* +* Multiply Q to the current block of C (I:I+NB,1:N) +* + CALL DTPMLQT('L','N',NB-K , N, K, 0,MB, A(1,I), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.M) THEN +* +* Multiply Q to the last block of C +* + CALL DTPMLQT('L','N',KK , N, K, 0, MB, A(1,II), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) +* + END IF +* + ELSE IF(RIGHT.AND.NOTRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((N-K),(NB-K)) + CTR = (N-K)/(NB-K) + IF (KK.GT.0) THEN + II=N-KK+1 + CALL DTPMLQT('R','N',M , KK, K, 0, MB, A(1, II), LDA, + $ T(1,CTR *K+1), LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) + ELSE + II=N+1 + END IF +* + DO I=II-(NB-K),NB+1,-(NB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CTR = CTR - 1 + CALL DTPMLQT('R','N', M, NB-K, K, 0, MB, A(1, I), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) +* + END DO +* +* Multiply Q to the first block of C (1:M,1:MB) +* + CALL DGEMLQT('R','N',M , NB, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (RIGHT.AND.TRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((N-K),(NB-K)) + CTR = 1 + II=N-KK+1 + CALL DGEMLQT('R','T',M , NB, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=NB+1,II-NB+K,(NB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CALL DTPMLQT('R','T',M , NB-K, K, 0,MB, A(1,I), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.N) THEN +* +* Multiply Q to the last block of C +* + CALL DTPMLQT('R','T',M , KK, K, 0,MB, A(1,II), LDA, + $ T(1,CTR*K+1),LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) +* + END IF +* + END IF +* + WORK(1) = LW + RETURN +* +* End of DLAMSWLQ +* + END diff --git a/math/lapack/src/main/fortran/dlamtsqr.f b/math/lapack/src/main/fortran/dlamtsqr.f new file mode 100644 index 0000000000..9ba45901b0 --- /dev/null +++ b/math/lapack/src/main/fortran/dlamtsqr.f @@ -0,0 +1,415 @@ +* +* Definition: +* =========== +* +* SUBROUTINE DLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, +* $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. +* DOUBLE A( LDA, * ), WORK( * ), C(LDC, * ), +* $ T( LDT, * ) +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAMTSQR 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 blocked elementary reflectors computed by tall skinny +*> QR factorization (DLATSQR) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> N >= K >= 0; +*> +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. +*> MB > N. (must be the same as DLATSQR) +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> N >= NB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> blockedelementary reflector H(i), for i = 1,2,...,k, as +*> returned by DLATSQR in the first k columns of +*> its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension +*> ( N * Number of blocks(CEIL(M-K/MB-K)), +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See below +*> for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> +*> \endverbatim +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> +*> If SIDE = 'L', LWORK >= max(1,N)*NB; +*> if SIDE = 'R', LWORK >= max(1,MB)*NB. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> +*> \endverbatim +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A: +*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A +*> . . . +*> +*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GEQRT. +*> +*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors +*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, + $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ), C(LDC, * ), + $ T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER I, II, KK, LW, CTR +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL DGEMQRT, DTPMQRT, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.LT.0 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'T' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + IF (LEFT) THEN + LW = N * NB + ELSE + LW = MB * NB + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, NB) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN + INFO = -15 + END IF +* +* Determine the block size if it is tall skinny or short and wide +* + IF( INFO.EQ.0) THEN + WORK(1) = LW + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAMTSQR', -INFO ) + RETURN + ELSE IF (LQUERY) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N,K).EQ.0 ) THEN + RETURN + END IF +* + IF((MB.LE.K).OR.(MB.GE.MAX(M,N,K))) THEN + CALL DGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA, + $ T, LDT, C, LDC, WORK, INFO) + RETURN + END IF +* + IF(LEFT.AND.NOTRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((M-K),(MB-K)) + CTR = (M-K)/(MB-K) + IF (KK.GT.0) THEN + II=M-KK+1 + CALL DTPMQRT('L','N',KK , N, K, 0, NB, A(II,1), LDA, + $ T(1,CTR*K+1),LDT , C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) + ELSE + II=M+1 + END IF +* + DO I=II-(MB-K),MB+1,-(MB-K) +* +* Multiply Q to the current block of C (I:I+MB,1:N) +* + CTR = CTR - 1 + CALL DTPMQRT('L','N',MB-K , N, K, 0,NB, A(I,1), LDA, + $ T(1,CTR*K+1),LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) +* + END DO +* +* Multiply Q to the first block of C (1:MB,1:N) +* + CALL DGEMQRT('L','N',MB , N, K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (LEFT.AND.TRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((M-K),(MB-K)) + II=M-KK+1 + CTR = 1 + CALL DGEMQRT('L','T',MB , N, K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=MB+1,II-MB+K,(MB-K) +* +* Multiply Q to the current block of C (I:I+MB,1:N) +* + CALL DTPMQRT('L','T',MB-K , N, K, 0,NB, A(I,1), LDA, + $ T(1,CTR * K + 1),LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.M) THEN +* +* Multiply Q to the last block of C +* + CALL DTPMQRT('L','T',KK , N, K, 0,NB, A(II,1), LDA, + $ T(1,CTR * K + 1), LDT, C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) +* + END IF +* + ELSE IF(RIGHT.AND.TRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((N-K),(MB-K)) + CTR = (N-K)/(MB-K) + IF (KK.GT.0) THEN + II=N-KK+1 + CALL DTPMQRT('R','T',M , KK, K, 0, NB, A(II,1), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) + ELSE + II=N+1 + END IF +* + DO I=II-(MB-K),MB+1,-(MB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CTR = CTR - 1 + CALL DTPMQRT('R','T',M , MB-K, K, 0,NB, A(I,1), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) +* + END DO +* +* Multiply Q to the first block of C (1:M,1:MB) +* + CALL DGEMQRT('R','T',M , MB, K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (RIGHT.AND.NOTRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((N-K),(MB-K)) + II=N-KK+1 + CTR = 1 + CALL DGEMQRT('R','N', M, MB , K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=MB+1,II-MB+K,(MB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CALL DTPMQRT('R','N', M, MB-K, K, 0,NB, A(I,1), LDA, + $ T(1, CTR * K + 1),LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.N) THEN +* +* Multiply Q to the last block of C +* + CALL DTPMQRT('R','N', M, KK , K, 0,NB, A(II,1), LDA, + $ T(1, CTR * K + 1),LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) +* + END IF +* + END IF +* + WORK(1) = LW + RETURN +* +* End of DLAMTSQR +* + END diff --git a/math/lapack/src/main/fortran/dlaneg.f b/math/lapack/src/main/fortran/dlaneg.f new file mode 100644 index 0000000000..3d13d316bb --- /dev/null +++ b/math/lapack/src/main/fortran/dlaneg.f @@ -0,0 +1,227 @@ +*> \brief \b DLANEG computes the Sturm count. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANEG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION DLANEG( N, D, LLD, SIGMA, PIVMIN, R ) +* +* .. Scalar Arguments .. +* INTEGER N, R +* DOUBLE PRECISION PIVMIN, SIGMA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), LLD( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLANEG computes the Sturm count, the number of negative pivots +*> encountered while factoring tridiagonal T - sigma I = L D L^T. +*> This implementation works directly on the factors without forming +*> the tridiagonal matrix T. The Sturm count is also the number of +*> eigenvalues of T less than sigma. +*> +*> This routine is called from DLARRB. +*> +*> The current routine does not use the PIVMIN parameter but rather +*> requires IEEE-754 propagation of Infinities and NaNs. This +*> routine also has no input range restrictions but does require +*> default exception handling such that x/0 produces Inf when x is +*> non-zero, and Inf/Inf produces NaN. For more information, see: +*> +*> Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in +*> Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on +*> Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624 +*> (Tech report version in LAWN 172 with the same title.) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The N diagonal elements of the diagonal matrix D. +*> \endverbatim +*> +*> \param[in] LLD +*> \verbatim +*> LLD is DOUBLE PRECISION array, dimension (N-1) +*> The (N-1) elements L(i)*L(i)*D(i). +*> \endverbatim +*> +*> \param[in] SIGMA +*> \verbatim +*> SIGMA is DOUBLE PRECISION +*> Shift amount in T - sigma I = L D L^T. +*> \endverbatim +*> +*> \param[in] PIVMIN +*> \verbatim +*> PIVMIN is DOUBLE PRECISION +*> The minimum pivot in the Sturm sequence. May be used +*> when zero pivots are encountered on non-IEEE-754 +*> architectures. +*> \endverbatim +*> +*> \param[in] R +*> \verbatim +*> R is INTEGER +*> The twist index for the twisted factorization that is used +*> for the negcount. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Osni Marques, LBNL/NERSC, USA \n +*> Christof Voemel, University of California, Berkeley, USA \n +*> Jason Riedy, University of California, Berkeley, USA \n +*> +* ===================================================================== + INTEGER FUNCTION DLANEG( N, D, LLD, SIGMA, PIVMIN, R ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER N, R + DOUBLE PRECISION PIVMIN, SIGMA +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), LLD( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* Some architectures propagate Infinities and NaNs very slowly, so +* the code computes counts in BLKLEN chunks. Then a NaN can +* propagate at most BLKLEN columns before being detected. This is +* not a general tuning parameter; it needs only to be just large +* enough that the overhead is tiny in common cases. + INTEGER BLKLEN + PARAMETER ( BLKLEN = 128 ) +* .. +* .. Local Scalars .. + INTEGER BJ, J, NEG1, NEG2, NEGCNT + DOUBLE PRECISION BSAV, DMINUS, DPLUS, GAMMA, P, T, TMP + LOGICAL SAWNAN +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN, MAX +* .. +* .. External Functions .. + LOGICAL DISNAN + EXTERNAL DISNAN +* .. +* .. Executable Statements .. + + NEGCNT = 0 + +* I) upper part: L D L^T - SIGMA I = L+ D+ L+^T + T = -SIGMA + DO 210 BJ = 1, R-1, BLKLEN + NEG1 = 0 + BSAV = T + DO 21 J = BJ, MIN(BJ+BLKLEN-1, R-1) + DPLUS = D( J ) + T + IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1 + TMP = T / DPLUS + T = TMP * LLD( J ) - SIGMA + 21 CONTINUE + SAWNAN = DISNAN( T ) +* Run a slower version of the above loop if a NaN is detected. +* A NaN should occur only with a zero pivot after an infinite +* pivot. In that case, substituting 1 for T/DPLUS is the +* correct limit. + IF( SAWNAN ) THEN + NEG1 = 0 + T = BSAV + DO 22 J = BJ, MIN(BJ+BLKLEN-1, R-1) + DPLUS = D( J ) + T + IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1 + TMP = T / DPLUS + IF (DISNAN(TMP)) TMP = ONE + T = TMP * LLD(J) - SIGMA + 22 CONTINUE + END IF + NEGCNT = NEGCNT + NEG1 + 210 CONTINUE +* +* II) lower part: L D L^T - SIGMA I = U- D- U-^T + P = D( N ) - SIGMA + DO 230 BJ = N-1, R, -BLKLEN + NEG2 = 0 + BSAV = P + DO 23 J = BJ, MAX(BJ-BLKLEN+1, R), -1 + DMINUS = LLD( J ) + P + IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1 + TMP = P / DMINUS + P = TMP * D( J ) - SIGMA + 23 CONTINUE + SAWNAN = DISNAN( P ) +* As above, run a slower version that substitutes 1 for Inf/Inf. +* + IF( SAWNAN ) THEN + NEG2 = 0 + P = BSAV + DO 24 J = BJ, MAX(BJ-BLKLEN+1, R), -1 + DMINUS = LLD( J ) + P + IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1 + TMP = P / DMINUS + IF (DISNAN(TMP)) TMP = ONE + P = TMP * D(J) - SIGMA + 24 CONTINUE + END IF + NEGCNT = NEGCNT + NEG2 + 230 CONTINUE +* +* III) Twist index +* T was shifted by SIGMA initially. + GAMMA = (T + SIGMA) + P + IF( GAMMA.LT.ZERO ) NEGCNT = NEGCNT+1 + + DLANEG = NEGCNT + END diff --git a/math/lapack/src/main/fortran/dlangb.f b/math/lapack/src/main/fortran/dlangb.f new file mode 100644 index 0000000000..078573b87a --- /dev/null +++ b/math/lapack/src/main/fortran/dlangb.f @@ -0,0 +1,225 @@ +*> \brief \b DLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of general band matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANGB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, +* WORK ) +* +* .. Scalar Arguments .. +* CHARACTER NORM +* INTEGER KL, KU, LDAB, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLANGB returns the value of the one norm, or the Frobenius norm, or +*> the infinity norm, or the element of largest absolute value of an +*> n by n band matrix A, with kl sub-diagonals and ku super-diagonals. +*> \endverbatim +*> +*> \return DLANGB +*> \verbatim +*> +*> DLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm' +*> ( +*> ( norm1(A), NORM = '1', 'O' or 'o' +*> ( +*> ( normI(A), NORM = 'I' or 'i' +*> ( +*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' +*> +*> where norm1 denotes the one norm of a matrix (maximum column sum), +*> normI denotes the infinity norm of a matrix (maximum row sum) and +*> normF denotes the Frobenius norm of a matrix (square root of sum of +*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in DLANGB as described +*> above. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. When N = 0, DLANGB is +*> set to zero. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of sub-diagonals of the matrix A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of super-diagonals of the matrix A. KU >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> The band matrix A, stored in rows 1 to KL+KU+1. The j-th +*> column of A is stored in the j-th column of the array AB as +*> follows: +*> AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KL+KU+1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +*> where LWORK >= N when NORM = 'I'; otherwise, WORK is not +*> referenced. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, + $ WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER KL, KU, LDAB, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, K, L + DOUBLE PRECISION SCALE, SUM, VALUE, TEMP +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + EXTERNAL LSAME, DISNAN +* .. +* .. 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 = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) + TEMP = ABS( AB( I, J ) ) + IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP + 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 = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) + SUM = SUM + ABS( AB( I, J ) ) + 30 CONTINUE + IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) 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 + K = KU + 1 - J + DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL ) + WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) ) + 60 CONTINUE + 70 CONTINUE + VALUE = ZERO + DO 80 I = 1, N + TEMP = WORK( I ) + IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP + 80 CONTINUE + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + DO 90 J = 1, N + L = MAX( 1, J-KU ) + K = KU + 1 - J + L + CALL DLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM ) + 90 CONTINUE + VALUE = SCALE*SQRT( SUM ) + END IF +* + DLANGB = VALUE + RETURN +* +* End of DLANGB +* + END diff --git a/math/lapack/src/main/fortran/dlange.f b/math/lapack/src/main/fortran/dlange.f new file mode 100644 index 0000000000..9dbf45e818 --- /dev/null +++ b/math/lapack/src/main/fortran/dlange.f @@ -0,0 +1,211 @@ +*> \brief \b DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general rectangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER NORM +* INTEGER LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +*> +*> \return DLANGE +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in DLANGE as described +*> above. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. When M = 0, +*> DLANGE is set to zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. When N = 0, +*> DLANGE is set to zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(M,1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +*> where LWORK >= M when NORM = 'I'; otherwise, WORK is not +*> referenced. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION SCALE, SUM, VALUE, TEMP +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + EXTERNAL LSAME, DISNAN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, 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 + TEMP = ABS( A( I, J ) ) + IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP + 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 + IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) 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 + TEMP = WORK( I ) + IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP + 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/math/lapack/src/main/fortran/dlangt.f b/math/lapack/src/main/fortran/dlangt.f new file mode 100644 index 0000000000..c9576c0c3d --- /dev/null +++ b/math/lapack/src/main/fortran/dlangt.f @@ -0,0 +1,208 @@ +*> \brief \b DLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general tridiagonal matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANGT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU ) +* +* .. Scalar Arguments .. +* CHARACTER NORM +* INTEGER N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), DL( * ), DU( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLANGT returns the value of the one norm, or the Frobenius norm, or +*> the infinity norm, or the element of largest absolute value of a +*> real tridiagonal matrix A. +*> \endverbatim +*> +*> \return DLANGT +*> \verbatim +*> +*> DLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm' +*> ( +*> ( norm1(A), NORM = '1', 'O' or 'o' +*> ( +*> ( normI(A), NORM = 'I' or 'i' +*> ( +*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' +*> +*> where norm1 denotes the one norm of a matrix (maximum column sum), +*> normI denotes the infinity norm of a matrix (maximum row sum) and +*> normF denotes the Frobenius norm of a matrix (square root of sum of +*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in DLANGT as described +*> above. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. When N = 0, DLANGT is +*> set to zero. +*> \endverbatim +*> +*> \param[in] DL +*> \verbatim +*> DL is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) sub-diagonal elements of A. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of A. +*> \endverbatim +*> +*> \param[in] DU +*> \verbatim +*> DU is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) super-diagonal elements of A. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), DL( * ), DU( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION ANORM, SCALE, SUM, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + EXTERNAL LSAME, DISNAN +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, 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 + IF( ANORM.LT.ABS( DL( I ) ) .OR. DISNAN( ABS( DL( I ) ) ) ) + $ ANORM = ABS(DL(I)) + IF( ANORM.LT.ABS( D( I ) ) .OR. DISNAN( ABS( D( I ) ) ) ) + $ ANORM = ABS(D(I)) + IF( ANORM.LT.ABS( DU( I ) ) .OR. DISNAN (ABS( DU( I ) ) ) ) + $ ANORM = ABS(DU(I)) + 10 CONTINUE + ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN +* +* Find norm1(A). +* + IF( N.EQ.1 ) THEN + ANORM = ABS( D( 1 ) ) + ELSE + ANORM = ABS( D( 1 ) )+ABS( DL( 1 ) ) + TEMP = ABS( D( N ) )+ABS( DU( N-1 ) ) + IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP + DO 20 I = 2, N - 1 + TEMP = ABS( D( I ) )+ABS( DL( I ) )+ABS( DU( I-1 ) ) + IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP + 20 CONTINUE + END IF + ELSE IF( LSAME( NORM, 'I' ) ) THEN +* +* Find normI(A). +* + IF( N.EQ.1 ) THEN + ANORM = ABS( D( 1 ) ) + ELSE + ANORM = ABS( D( 1 ) )+ABS( DU( 1 ) ) + TEMP = ABS( D( N ) )+ABS( DL( N-1 ) ) + IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP + DO 30 I = 2, N - 1 + TEMP = ABS( D( I ) )+ABS( DU( I ) )+ABS( DL( I-1 ) ) + IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP + 30 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + CALL DLASSQ( N, D, 1, SCALE, SUM ) + IF( N.GT.1 ) THEN + CALL DLASSQ( N-1, DL, 1, SCALE, SUM ) + CALL DLASSQ( N-1, DU, 1, SCALE, SUM ) + END IF + ANORM = SCALE*SQRT( SUM ) + END IF +* + DLANGT = ANORM + RETURN +* +* End of DLANGT +* + END diff --git a/math/lapack/src/main/fortran/dlanhs.f b/math/lapack/src/main/fortran/dlanhs.f new file mode 100644 index 0000000000..691dbc21ec --- /dev/null +++ b/math/lapack/src/main/fortran/dlanhs.f @@ -0,0 +1,205 @@ +*> \brief \b DLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of an upper Hessenberg matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANHS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER NORM +* INTEGER LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +*> +*> \return DLANHS +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in DLANHS as described +*> above. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. When N = 0, DLANHS is +*> set to zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(N,1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +*> where LWORK >= N when NORM = 'I'; otherwise, WORK is not +*> referenced. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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, DISNAN + EXTERNAL LSAME, DISNAN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, 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 ) + SUM = ABS( A( I, J ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 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 + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) 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 + SUM = WORK( I ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 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/math/lapack/src/main/fortran/dlansb.f b/math/lapack/src/main/fortran/dlansb.f new file mode 100644 index 0000000000..4ccf5f27e1 --- /dev/null +++ b/math/lapack/src/main/fortran/dlansb.f @@ -0,0 +1,258 @@ +*> \brief \b DLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric band matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANSB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, +* WORK ) +* +* .. Scalar Arguments .. +* CHARACTER NORM, UPLO +* INTEGER K, LDAB, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLANSB returns the value of the one norm, or the Frobenius norm, or +*> the infinity norm, or the element of largest absolute value of an +*> n by n symmetric band matrix A, with k super-diagonals. +*> \endverbatim +*> +*> \return DLANSB +*> \verbatim +*> +*> DLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm' +*> ( +*> ( norm1(A), NORM = '1', 'O' or 'o' +*> ( +*> ( normI(A), NORM = 'I' or 'i' +*> ( +*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' +*> +*> where norm1 denotes the one norm of a matrix (maximum column sum), +*> normI denotes the infinity norm of a matrix (maximum row sum) and +*> normF denotes the Frobenius norm of a matrix (square root of sum of +*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in DLANSB as described +*> above. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> band matrix A is supplied. +*> = 'U': Upper triangular part is supplied +*> = 'L': Lower triangular part is supplied +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. When N = 0, DLANSB is +*> set to zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of super-diagonals or sub-diagonals of the +*> band matrix A. K >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> The upper or lower triangle of the symmetric band matrix A, +*> stored in the first K+1 rows of AB. The j-th column of A is +*> stored in the j-th column of the array AB as follows: +*> if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= K+1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, +*> WORK is not referenced. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, + $ WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER NORM, UPLO + INTEGER K, LDAB, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, L + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + EXTERNAL LSAME, DISNAN +* .. +* .. 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 + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = MAX( K+2-J, 1 ), K + 1 + SUM = ABS( AB( I, J ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = 1, MIN( N+1-J, K+1 ) + SUM = ABS( AB( I, J ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 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 + L = K + 1 - J + DO 50 I = MAX( 1, J-K ), J - 1 + ABSA = ABS( AB( L+I, J ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + 50 CONTINUE + WORK( J ) = SUM + ABS( AB( K+1, J ) ) + 60 CONTINUE + DO 70 I = 1, N + SUM = WORK( I ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 70 CONTINUE + ELSE + DO 80 I = 1, N + WORK( I ) = ZERO + 80 CONTINUE + DO 100 J = 1, N + SUM = WORK( J ) + ABS( AB( 1, J ) ) + L = 1 - J + DO 90 I = J + 1, MIN( N, J+K ) + ABSA = ABS( AB( L+I, J ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + 90 CONTINUE + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 100 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + IF( K.GT.0 ) THEN + IF( LSAME( UPLO, 'U' ) ) THEN + DO 110 J = 2, N + CALL DLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ), + $ 1, SCALE, SUM ) + 110 CONTINUE + L = K + 1 + ELSE + DO 120 J = 1, N - 1 + CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, + $ SUM ) + 120 CONTINUE + L = 1 + END IF + SUM = 2*SUM + ELSE + L = 1 + END IF + CALL DLASSQ( N, AB( L, 1 ), LDAB, SCALE, SUM ) + VALUE = SCALE*SQRT( SUM ) + END IF +* + DLANSB = VALUE + RETURN +* +* End of DLANSB +* + END diff --git a/math/lapack/src/main/fortran/dlansf.f b/math/lapack/src/main/fortran/dlansf.f new file mode 100644 index 0000000000..d9b6c5b361 --- /dev/null +++ b/math/lapack/src/main/fortran/dlansf.f @@ -0,0 +1,963 @@ +*> \brief \b DLANSF returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix in RFP format. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANSF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER NORM, TRANSR, UPLO +* INTEGER N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( 0: * ), WORK( 0: * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLANSF returns the value of the one norm, or the Frobenius norm, or +*> the infinity norm, or the element of largest absolute value of a +*> real symmetric matrix A in RFP format. +*> \endverbatim +*> +*> \return DLANSF +*> \verbatim +*> +*> DLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm' +*> ( +*> ( norm1(A), NORM = '1', 'O' or 'o' +*> ( +*> ( normI(A), NORM = 'I' or 'i' +*> ( +*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' +*> +*> where norm1 denotes the one norm of a matrix (maximum column sum), +*> normI denotes the infinity norm of a matrix (maximum row sum) and +*> normF denotes the Frobenius norm of a matrix (square root of sum of +*> squares). Note that max(abs(A(i,j))) is not a matrix norm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in DLANSF as described +*> above. +*> \endverbatim +*> +*> \param[in] TRANSR +*> \verbatim +*> TRANSR is CHARACTER*1 +*> Specifies whether the RFP format of A is normal or +*> transposed format. +*> = 'N': RFP format is Normal; +*> = 'T': RFP format is Transpose. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the RFP matrix A came from +*> an upper or lower triangular matrix as follows: +*> = 'U': RFP A came from an upper triangular matrix; +*> = 'L': RFP A came from a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. When N = 0, DLANSF is +*> set to zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ); +*> On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') +*> part of the symmetric matrix A stored in RFP format. See the +*> "Notes" below for more details. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, +*> WORK is not referenced. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> We first consider Rectangular Full Packed (RFP) Format when N is +*> even. We give an example where N = 6. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 05 00 +*> 11 12 13 14 15 10 11 +*> 22 23 24 25 20 21 22 +*> 33 34 35 30 31 32 33 +*> 44 45 40 41 42 43 44 +*> 55 50 51 52 53 54 55 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(4:6,0:2) consists of +*> the transpose of the first three columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:2,0:2) consists of +*> the transpose of the last three columns of AP lower. +*> This covers the case N even and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 03 04 05 33 43 53 +*> 13 14 15 00 44 54 +*> 23 24 25 10 11 55 +*> 33 34 35 20 21 22 +*> 00 44 45 30 31 32 +*> 01 11 55 40 41 42 +*> 02 12 22 50 51 52 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> +*> RFP A RFP A +*> +*> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +*> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +*> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +*> +*> +*> We then consider Rectangular Full Packed (RFP) Format when N is +*> odd. We give an example where N = 5. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 00 +*> 11 12 13 14 10 11 +*> 22 23 24 20 21 22 +*> 33 34 30 31 32 33 +*> 44 40 41 42 43 44 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(3:4,0:1) consists of +*> the transpose of the first two columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:1,1:2) consists of +*> the transpose of the last two columns of AP lower. +*> This covers the case N odd and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 02 03 04 00 33 43 +*> 12 13 14 10 11 44 +*> 22 23 24 20 21 22 +*> 00 33 34 30 31 32 +*> 01 11 44 40 41 42 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> RFP A RFP A +*> +*> 02 12 22 00 01 00 10 20 30 40 50 +*> 03 13 23 33 11 33 11 21 31 41 51 +*> 04 14 24 34 44 43 44 22 32 42 52 +*> \endverbatim +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER NORM, TRANSR, UPLO + INTEGER N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( 0: * ), WORK( 0: * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, IFM, ILU, NOE, N1, K, L, LDA + DOUBLE PRECISION SCALE, S, VALUE, AA, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + EXTERNAL LSAME, DISNAN +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* + IF( N.EQ.0 ) THEN + DLANSF = ZERO + RETURN + ELSE IF( N.EQ.1 ) THEN + DLANSF = ABS( A(0) ) + RETURN + END IF +* +* set noe = 1 if n is odd. if n is even set noe=0 +* + NOE = 1 + IF( MOD( N, 2 ).EQ.0 ) + $ NOE = 0 +* +* set ifm = 0 when form='T or 't' and 1 otherwise +* + IFM = 1 + IF( LSAME( TRANSR, 'T' ) ) + $ IFM = 0 +* +* set ilu = 0 when uplo='U or 'u' and 1 otherwise +* + ILU = 1 + IF( LSAME( UPLO, 'U' ) ) + $ ILU = 0 +* +* set lda = (n+1)/2 when ifm = 0 +* set lda = n when ifm = 1 and noe = 1 +* set lda = n+1 when ifm = 1 and noe = 0 +* + IF( IFM.EQ.1 ) THEN + IF( NOE.EQ.1 ) THEN + LDA = N + ELSE +* noe=0 + LDA = N + 1 + END IF + ELSE +* ifm=0 + LDA = ( N+1 ) / 2 + END IF +* + IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + K = ( N+1 ) / 2 + VALUE = ZERO + IF( NOE.EQ.1 ) THEN +* n is odd + IF( IFM.EQ.1 ) THEN +* A is n by k + DO J = 0, K - 1 + DO I = 0, N - 1 + TEMP = ABS( A( I+J*LDA ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + $ VALUE = TEMP + END DO + END DO + ELSE +* xpose case; A is k by n + DO J = 0, N - 1 + DO I = 0, K - 1 + TEMP = ABS( A( I+J*LDA ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + $ VALUE = TEMP + END DO + END DO + END IF + ELSE +* n is even + IF( IFM.EQ.1 ) THEN +* A is n+1 by k + DO J = 0, K - 1 + DO I = 0, N + TEMP = ABS( A( I+J*LDA ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + $ VALUE = TEMP + END DO + END DO + ELSE +* xpose case; A is k by n+1 + DO J = 0, N + DO I = 0, K - 1 + TEMP = ABS( A( I+J*LDA ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + $ VALUE = TEMP + END DO + END DO + END IF + END IF + ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. + $ ( NORM.EQ.'1' ) ) THEN +* +* Find normI(A) ( = norm1(A), since A is symmetric). +* + IF( IFM.EQ.1 ) THEN + K = N / 2 + IF( NOE.EQ.1 ) THEN +* n is odd + IF( ILU.EQ.0 ) THEN + DO I = 0, K - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K + S = ZERO + DO I = 0, K + J - 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(i,j+k) + S = S + AA + WORK( I ) = WORK( I ) + AA + END DO + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,j+k) + WORK( J+K ) = S + AA + IF( I.EQ.K+K ) + $ GO TO 10 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(j,j) + WORK( J ) = WORK( J ) + AA + S = ZERO + DO L = J + 1, K - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + 10 CONTINUE + VALUE = WORK( 0 ) + DO I = 1, N-1 + TEMP = WORK( I ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + $ VALUE = TEMP + END DO + ELSE +* ilu = 1 + K = K + 1 +* k=(n+1)/2 for n odd and ilu=1 + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = K - 1, 0, -1 + S = ZERO + DO I = 0, J - 2 + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,i+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + AA + END DO + IF( J.GT.0 ) THEN + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,j+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + S +* i=j + I = I + 1 + END IF + AA = ABS( A( I+J*LDA ) ) +* -> A(j,j) + WORK( J ) = AA + S = ZERO + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + VALUE = WORK( 0 ) + DO I = 1, N-1 + TEMP = WORK( I ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + $ VALUE = TEMP + END DO + END IF + ELSE +* n is even + IF( ILU.EQ.0 ) THEN + DO I = 0, K - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K - 1 + S = ZERO + DO I = 0, K + J - 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(i,j+k) + S = S + AA + WORK( I ) = WORK( I ) + AA + END DO + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,j+k) + WORK( J+K ) = S + AA + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(j,j) + WORK( J ) = WORK( J ) + AA + S = ZERO + DO L = J + 1, K - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + VALUE = WORK( 0 ) + DO I = 1, N-1 + TEMP = WORK( I ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + $ VALUE = TEMP + END DO + ELSE +* ilu = 1 + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = K - 1, 0, -1 + S = ZERO + DO I = 0, J - 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,i+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + AA + END DO + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,j+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + S +* i=j + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(j,j) + WORK( J ) = AA + S = ZERO + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + VALUE = WORK( 0 ) + DO I = 1, N-1 + TEMP = WORK( I ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + $ VALUE = TEMP + END DO + END IF + END IF + ELSE +* ifm=0 + K = N / 2 + IF( NOE.EQ.1 ) THEN +* n is odd + IF( ILU.EQ.0 ) THEN + N1 = K +* n/2 + K = K + 1 +* k is the row size and lda + DO I = N1, N - 1 + WORK( I ) = ZERO + END DO + DO J = 0, N1 - 1 + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,n1+i) + WORK( I+N1 ) = WORK( I+N1 ) + AA + S = S + AA + END DO + WORK( J ) = S + END DO +* j=n1=k-1 is special + S = ABS( A( 0+J*LDA ) ) +* A(k-1,k-1) + DO I = 1, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(k-1,i+n1) + WORK( I+N1 ) = WORK( I+N1 ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + DO J = K, N - 1 + S = ZERO + DO I = 0, J - K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(i,j-k) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=j-k + AA = ABS( A( I+J*LDA ) ) +* A(j-k,j-k) + S = S + AA + WORK( J-K ) = WORK( J-K ) + S + I = I + 1 + S = ABS( A( I+J*LDA ) ) +* A(j,j) + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,l) + WORK( L ) = WORK( L ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + VALUE = WORK( 0 ) + DO I = 1, N-1 + TEMP = WORK( I ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + $ VALUE = TEMP + END DO + ELSE +* ilu=1 + K = K + 1 +* k=(n+1)/2 for n odd and ilu=1 + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K - 2 +* process + S = ZERO + DO I = 0, J - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + AA = ABS( A( I+J*LDA ) ) +* i=j so process of A(j,j) + S = S + AA + WORK( J ) = S +* is initialised here + I = I + 1 +* i=j process A(j+k,j+k) + AA = ABS( A( I+J*LDA ) ) + S = AA + DO L = K + J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(l,k+j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( K+J ) = WORK( K+J ) + S + END DO +* j=k-1 is special :process col A(k-1,0:k-1) + S = ZERO + DO I = 0, K - 2 + AA = ABS( A( I+J*LDA ) ) +* A(k,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=k-1 + AA = ABS( A( I+J*LDA ) ) +* A(k-1,k-1) + S = S + AA + WORK( I ) = S +* done with col j=k+1 + DO J = K, N - 1 +* process col j of A = A(j,0:k-1) + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + VALUE = WORK( 0 ) + DO I = 1, N-1 + TEMP = WORK( I ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + $ VALUE = TEMP + END DO + END IF + ELSE +* n is even + IF( ILU.EQ.0 ) THEN + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K - 1 + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,i+k) + WORK( I+K ) = WORK( I+K ) + AA + S = S + AA + END DO + WORK( J ) = S + END DO +* j=k + AA = ABS( A( 0+J*LDA ) ) +* A(k,k) + S = AA + DO I = 1, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(k,k+i) + WORK( I+K ) = WORK( I+K ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + DO J = K + 1, N - 1 + S = ZERO + DO I = 0, J - 2 - K + AA = ABS( A( I+J*LDA ) ) +* A(i,j-k-1) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=j-1-k + AA = ABS( A( I+J*LDA ) ) +* A(j-k-1,j-k-1) + S = S + AA + WORK( J-K-1 ) = WORK( J-K-1 ) + S + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,j) + S = AA + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,l) + WORK( L ) = WORK( L ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + END DO +* j=n + S = ZERO + DO I = 0, K - 2 + AA = ABS( A( I+J*LDA ) ) +* A(i,k-1) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=k-1 + AA = ABS( A( I+J*LDA ) ) +* A(k-1,k-1) + S = S + AA + WORK( I ) = WORK( I ) + S + VALUE = WORK( 0 ) + DO I = 1, N-1 + TEMP = WORK( I ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + $ VALUE = TEMP + END DO + ELSE +* ilu=1 + DO I = K, N - 1 + WORK( I ) = ZERO + END DO +* j=0 is special :process col A(k:n-1,k) + S = ABS( A( 0 ) ) +* A(k,k) + DO I = 1, K - 1 + AA = ABS( A( I ) ) +* A(k+i,k) + WORK( I+K ) = WORK( I+K ) + AA + S = S + AA + END DO + WORK( K ) = WORK( K ) + S + DO J = 1, K - 1 +* process + S = ZERO + DO I = 0, J - 2 + AA = ABS( A( I+J*LDA ) ) +* A(j-1,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + AA = ABS( A( I+J*LDA ) ) +* i=j-1 so process of A(j-1,j-1) + S = S + AA + WORK( J-1 ) = S +* is initialised here + I = I + 1 +* i=j process A(j+k,j+k) + AA = ABS( A( I+J*LDA ) ) + S = AA + DO L = K + J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(l,k+j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( K+J ) = WORK( K+J ) + S + END DO +* j=k is special :process col A(k,0:k-1) + S = ZERO + DO I = 0, K - 2 + AA = ABS( A( I+J*LDA ) ) +* A(k,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=k-1 + AA = ABS( A( I+J*LDA ) ) +* A(k-1,k-1) + S = S + AA + WORK( I ) = S +* done with col j=k+1 + DO J = K + 1, N +* process col j-1 of A = A(j-1,0:k-1) + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j-1,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + WORK( J-1 ) = WORK( J-1 ) + S + END DO + VALUE = WORK( 0 ) + DO I = 1, N-1 + TEMP = WORK( I ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + $ VALUE = TEMP + END DO + END IF + END IF + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + K = ( N+1 ) / 2 + SCALE = ZERO + S = ONE + IF( NOE.EQ.1 ) THEN +* n is odd + IF( IFM.EQ.1 ) THEN +* A is normal + IF( ILU.EQ.0 ) THEN +* A is upper + DO J = 0, K - 3 + CALL DLASSQ( K-J-2, A( K+J+1+J*LDA ), 1, SCALE, S ) +* L at A(k,0) + END DO + DO J = 0, K - 1 + CALL DLASSQ( K+J-1, A( 0+J*LDA ), 1, SCALE, S ) +* trap U at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + CALL DLASSQ( K-1, A( K ), LDA+1, SCALE, S ) +* tri L at A(k,0) + CALL DLASSQ( K, A( K-1 ), LDA+1, SCALE, S ) +* tri U at A(k-1,0) + ELSE +* ilu=1 & A is lower + DO J = 0, K - 1 + CALL DLASSQ( N-J-1, A( J+1+J*LDA ), 1, SCALE, S ) +* trap L at A(0,0) + END DO + DO J = 0, K - 2 + CALL DLASSQ( J, A( 0+( 1+J )*LDA ), 1, SCALE, S ) +* U at A(0,1) + END DO + S = S + S +* double s for the off diagonal elements + CALL DLASSQ( K, A( 0 ), LDA+1, SCALE, S ) +* tri L at A(0,0) + CALL DLASSQ( K-1, A( 0+LDA ), LDA+1, SCALE, S ) +* tri U at A(0,1) + END IF + ELSE +* A is xpose + IF( ILU.EQ.0 ) THEN +* A**T is upper + DO J = 1, K - 2 + CALL DLASSQ( J, A( 0+( K+J )*LDA ), 1, SCALE, S ) +* U at A(0,k) + END DO + DO J = 0, K - 2 + CALL DLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k-1 rect. at A(0,0) + END DO + DO J = 0, K - 2 + CALL DLASSQ( K-J-1, A( J+1+( J+K-1 )*LDA ), 1, + $ SCALE, S ) +* L at A(0,k-1) + END DO + S = S + S +* double s for the off diagonal elements + CALL DLASSQ( K-1, A( 0+K*LDA ), LDA+1, SCALE, S ) +* tri U at A(0,k) + CALL DLASSQ( K, A( 0+( K-1 )*LDA ), LDA+1, SCALE, S ) +* tri L at A(0,k-1) + ELSE +* A**T is lower + DO J = 1, K - 1 + CALL DLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) +* U at A(0,0) + END DO + DO J = K, N - 1 + CALL DLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k-1 rect. at A(0,k) + END DO + DO J = 0, K - 3 + CALL DLASSQ( K-J-2, A( J+2+J*LDA ), 1, SCALE, S ) +* L at A(1,0) + END DO + S = S + S +* double s for the off diagonal elements + CALL DLASSQ( K, A( 0 ), LDA+1, SCALE, S ) +* tri U at A(0,0) + CALL DLASSQ( K-1, A( 1 ), LDA+1, SCALE, S ) +* tri L at A(1,0) + END IF + END IF + ELSE +* n is even + IF( IFM.EQ.1 ) THEN +* A is normal + IF( ILU.EQ.0 ) THEN +* A is upper + DO J = 0, K - 2 + CALL DLASSQ( K-J-1, A( K+J+2+J*LDA ), 1, SCALE, S ) +* L at A(k+1,0) + END DO + DO J = 0, K - 1 + CALL DLASSQ( K+J, A( 0+J*LDA ), 1, SCALE, S ) +* trap U at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + CALL DLASSQ( K, A( K+1 ), LDA+1, SCALE, S ) +* tri L at A(k+1,0) + CALL DLASSQ( K, A( K ), LDA+1, SCALE, S ) +* tri U at A(k,0) + ELSE +* ilu=1 & A is lower + DO J = 0, K - 1 + CALL DLASSQ( N-J-1, A( J+2+J*LDA ), 1, SCALE, S ) +* trap L at A(1,0) + END DO + DO J = 1, K - 1 + CALL DLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) +* U at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + CALL DLASSQ( K, A( 1 ), LDA+1, SCALE, S ) +* tri L at A(1,0) + CALL DLASSQ( K, A( 0 ), LDA+1, SCALE, S ) +* tri U at A(0,0) + END IF + ELSE +* A is xpose + IF( ILU.EQ.0 ) THEN +* A**T is upper + DO J = 1, K - 1 + CALL DLASSQ( J, A( 0+( K+1+J )*LDA ), 1, SCALE, S ) +* U at A(0,k+1) + END DO + DO J = 0, K - 1 + CALL DLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k rect. at A(0,0) + END DO + DO J = 0, K - 2 + CALL DLASSQ( K-J-1, A( J+1+( J+K )*LDA ), 1, SCALE, + $ S ) +* L at A(0,k) + END DO + S = S + S +* double s for the off diagonal elements + CALL DLASSQ( K, A( 0+( K+1 )*LDA ), LDA+1, SCALE, S ) +* tri U at A(0,k+1) + CALL DLASSQ( K, A( 0+K*LDA ), LDA+1, SCALE, S ) +* tri L at A(0,k) + ELSE +* A**T is lower + DO J = 1, K - 1 + CALL DLASSQ( J, A( 0+( J+1 )*LDA ), 1, SCALE, S ) +* U at A(0,1) + END DO + DO J = K + 1, N + CALL DLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k rect. at A(0,k+1) + END DO + DO J = 0, K - 2 + CALL DLASSQ( K-J-1, A( J+1+J*LDA ), 1, SCALE, S ) +* L at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + CALL DLASSQ( K, A( LDA ), LDA+1, SCALE, S ) +* tri L at A(0,1) + CALL DLASSQ( K, A( 0 ), LDA+1, SCALE, S ) +* tri U at A(0,0) + END IF + END IF + END IF + VALUE = SCALE*SQRT( S ) + END IF +* + DLANSF = VALUE + RETURN +* +* End of DLANSF +* + END diff --git a/math/lapack/src/main/fortran/dlansp.f b/math/lapack/src/main/fortran/dlansp.f new file mode 100644 index 0000000000..a1829db75c --- /dev/null +++ b/math/lapack/src/main/fortran/dlansp.f @@ -0,0 +1,261 @@ +*> \brief \b DLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix supplied in packed form. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANSP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER NORM, UPLO +* INTEGER N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +*> +*> \return DLANSP +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in DLANSP as described +*> above. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is 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 +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. When N = 0, DLANSP is +*> set to zero. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is 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. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, +*> WORK is not referenced. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER NORM, UPLO + INTEGER N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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, DISNAN + EXTERNAL LSAME, DISNAN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, 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 + SUM = ABS( AP( I ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 10 CONTINUE + K = K + J + 20 CONTINUE + ELSE + K = 1 + DO 40 J = 1, N + DO 30 I = K, K + N - J + SUM = ABS( AP( I ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 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 + SUM = WORK( I ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 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 + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) 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/math/lapack/src/main/fortran/dlanst.f b/math/lapack/src/main/fortran/dlanst.f new file mode 100644 index 0000000000..e952e2dd21 --- /dev/null +++ b/math/lapack/src/main/fortran/dlanst.f @@ -0,0 +1,186 @@ +*> \brief \b DLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) +* +* .. Scalar Arguments .. +* CHARACTER NORM +* INTEGER N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +*> +*> \return DLANST +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in DLANST as described +*> above. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. When N = 0, DLANST is +*> set to zero. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of A. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) sub-diagonal or super-diagonal elements of A. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) +* .. +* +* ===================================================================== +* +* .. 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, DISNAN + EXTERNAL LSAME, DISNAN +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, 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 + SUM = ABS( D( I ) ) + IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM + SUM = ABS( E( I ) ) + IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM + 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 = ABS( D( 1 ) )+ABS( E( 1 ) ) + SUM = ABS( E( N-1 ) )+ABS( D( N ) ) + IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM + DO 20 I = 2, N - 1 + SUM = ABS( D( I ) )+ABS( E( I ) )+ABS( E( I-1 ) ) + IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM + 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/math/lapack/src/main/fortran/dlansy.f b/math/lapack/src/main/fortran/dlansy.f new file mode 100644 index 0000000000..2372fce0a8 --- /dev/null +++ b/math/lapack/src/main/fortran/dlansy.f @@ -0,0 +1,241 @@ +*> \brief \b DLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANSY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER NORM, UPLO +* INTEGER LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +*> +*> \return DLANSY +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in DLANSY as described +*> above. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is 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 +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. When N = 0, DLANSY is +*> set to zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(N,1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, +*> WORK is not referenced. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER NORM, UPLO + INTEGER LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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, DISNAN + EXTERNAL LSAME, DISNAN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, 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 + SUM = ABS( A( I, J ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J, N + SUM = ABS( A( I, J ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 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 + SUM = WORK( I ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 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 + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) 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/math/lapack/src/main/fortran/dlantb.f b/math/lapack/src/main/fortran/dlantb.f new file mode 100644 index 0000000000..3d2bfe7e4b --- /dev/null +++ b/math/lapack/src/main/fortran/dlantb.f @@ -0,0 +1,361 @@ +*> \brief \b DLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular band matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANTB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, +* LDAB, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, NORM, UPLO +* INTEGER K, LDAB, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLANTB returns the value of the one norm, or the Frobenius norm, or +*> the infinity norm, or the element of largest absolute value of an +*> n by n triangular band matrix A, with ( k + 1 ) diagonals. +*> \endverbatim +*> +*> \return DLANTB +*> \verbatim +*> +*> DLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm' +*> ( +*> ( norm1(A), NORM = '1', 'O' or 'o' +*> ( +*> ( normI(A), NORM = 'I' or 'i' +*> ( +*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' +*> +*> where norm1 denotes the one norm of a matrix (maximum column sum), +*> normI denotes the infinity norm of a matrix (maximum row sum) and +*> normF denotes the Frobenius norm of a matrix (square root of sum of +*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in DLANTB as described +*> above. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the matrix A is upper or lower triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the matrix A is unit triangular. +*> = 'N': Non-unit triangular +*> = 'U': Unit triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. When N = 0, DLANTB is +*> set to zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of super-diagonals of the matrix A if UPLO = 'U', +*> or the number of sub-diagonals of the matrix A if UPLO = 'L'. +*> K >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> The upper or lower triangular band matrix A, stored in the +*> first k+1 rows of AB. The j-th column of A is stored +*> in the j-th column of the array AB as follows: +*> if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). +*> Note that when DIAG = 'U', the elements of the array AB +*> corresponding to the diagonal elements of the matrix A are +*> not referenced, but are assumed to be one. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= K+1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +*> where LWORK >= N when NORM = 'I'; otherwise, WORK is not +*> referenced. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, + $ LDAB, WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, NORM, UPLO + INTEGER K, LDAB, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UDIAG + INTEGER I, J, L + DOUBLE PRECISION SCALE, SUM, VALUE +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + EXTERNAL LSAME, DISNAN +* .. +* .. 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))). +* + IF( LSAME( DIAG, 'U' ) ) THEN + VALUE = ONE + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = MAX( K+2-J, 1 ), K + SUM = ABS( AB( I, J ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = 2, MIN( N+1-J, K+1 ) + SUM = ABS( AB( I, J ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 60 J = 1, N + DO 50 I = MAX( K+2-J, 1 ), K + 1 + SUM = ABS( AB( I, J ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1, N + DO 70 I = 1, MIN( N+1-J, K+1 ) + SUM = ABS( AB( I, J ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 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 ) THEN + SUM = ONE + DO 90 I = MAX( K+2-J, 1 ), K + SUM = SUM + ABS( AB( I, J ) ) + 90 CONTINUE + ELSE + SUM = ZERO + DO 100 I = MAX( K+2-J, 1 ), K + 1 + SUM = SUM + ABS( AB( I, J ) ) + 100 CONTINUE + END IF + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 110 CONTINUE + ELSE + DO 140 J = 1, N + IF( UDIAG ) THEN + SUM = ONE + DO 120 I = 2, MIN( N+1-J, K+1 ) + SUM = SUM + ABS( AB( I, J ) ) + 120 CONTINUE + ELSE + SUM = ZERO + DO 130 I = 1, MIN( N+1-J, K+1 ) + SUM = SUM + ABS( AB( I, J ) ) + 130 CONTINUE + END IF + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 140 CONTINUE + END IF + ELSE IF( LSAME( NORM, 'I' ) ) THEN +* +* Find normI(A). +* + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + IF( LSAME( DIAG, 'U' ) ) THEN + DO 150 I = 1, N + WORK( I ) = ONE + 150 CONTINUE + DO 170 J = 1, N + L = K + 1 - J + DO 160 I = MAX( 1, J-K ), J - 1 + WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) + 160 CONTINUE + 170 CONTINUE + ELSE + DO 180 I = 1, N + WORK( I ) = ZERO + 180 CONTINUE + DO 200 J = 1, N + L = K + 1 - J + DO 190 I = MAX( 1, J-K ), J + WORK( I ) = WORK( I ) + ABS( AB( L+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 230 J = 1, N + L = 1 - J + DO 220 I = J + 1, MIN( N, J+K ) + WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) + 220 CONTINUE + 230 CONTINUE + ELSE + DO 240 I = 1, N + WORK( I ) = ZERO + 240 CONTINUE + DO 260 J = 1, N + L = 1 - J + DO 250 I = J, MIN( N, J+K ) + WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) + 250 CONTINUE + 260 CONTINUE + END IF + END IF + DO 270 I = 1, N + SUM = WORK( I ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 270 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 = N + IF( K.GT.0 ) THEN + DO 280 J = 2, N + CALL DLASSQ( MIN( J-1, K ), + $ AB( MAX( K+2-J, 1 ), J ), 1, SCALE, + $ SUM ) + 280 CONTINUE + END IF + ELSE + SCALE = ZERO + SUM = ONE + DO 290 J = 1, N + CALL DLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ), + $ 1, SCALE, SUM ) + 290 CONTINUE + END IF + ELSE + IF( LSAME( DIAG, 'U' ) ) THEN + SCALE = ONE + SUM = N + IF( K.GT.0 ) THEN + DO 300 J = 1, N - 1 + CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, + $ SUM ) + 300 CONTINUE + END IF + ELSE + SCALE = ZERO + SUM = ONE + DO 310 J = 1, N + CALL DLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE, + $ SUM ) + 310 CONTINUE + END IF + END IF + VALUE = SCALE*SQRT( SUM ) + END IF +* + DLANTB = VALUE + RETURN +* +* End of DLANTB +* + END diff --git a/math/lapack/src/main/fortran/dlantp.f b/math/lapack/src/main/fortran/dlantp.f new file mode 100644 index 0000000000..f84a9e9d7d --- /dev/null +++ b/math/lapack/src/main/fortran/dlantp.f @@ -0,0 +1,355 @@ +*> \brief \b DLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular matrix supplied in packed form. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANTP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, NORM, UPLO +* INTEGER N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLANTP returns the value of the one norm, or the Frobenius norm, or +*> the infinity norm, or the element of largest absolute value of a +*> triangular matrix A, supplied in packed form. +*> \endverbatim +*> +*> \return DLANTP +*> \verbatim +*> +*> DLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm' +*> ( +*> ( norm1(A), NORM = '1', 'O' or 'o' +*> ( +*> ( normI(A), NORM = 'I' or 'i' +*> ( +*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' +*> +*> where norm1 denotes the one norm of a matrix (maximum column sum), +*> normI denotes the infinity norm of a matrix (maximum row sum) and +*> normF denotes the Frobenius norm of a matrix (square root of sum of +*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in DLANTP as described +*> above. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the matrix A is upper or lower triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the matrix A is unit triangular. +*> = 'N': Non-unit triangular +*> = 'U': Unit triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. When N = 0, DLANTP is +*> set to zero. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> The upper or lower triangular matrix A, packed columnwise in +*> a linear array. The j-th column of A is stored in the array +*> AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +*> Note that when DIAG = 'U', the elements of the array AP +*> corresponding to the diagonal elements of the matrix A are +*> not referenced, but are assumed to be one. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +*> where LWORK >= N when NORM = 'I'; otherwise, WORK is not +*> referenced. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, NORM, UPLO + INTEGER N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UDIAG + INTEGER I, J, K + DOUBLE PRECISION SCALE, SUM, VALUE +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + EXTERNAL LSAME, DISNAN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* + IF( N.EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + K = 1 + IF( LSAME( DIAG, 'U' ) ) THEN + VALUE = ONE + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = K, K + J - 2 + SUM = ABS( AP( I ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 10 CONTINUE + K = K + J + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = K + 1, K + N - J + SUM = ABS( AP( I ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 30 CONTINUE + K = K + N - J + 1 + 40 CONTINUE + END IF + ELSE + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 60 J = 1, N + DO 50 I = K, K + J - 1 + SUM = ABS( AP( I ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 50 CONTINUE + K = K + J + 60 CONTINUE + ELSE + DO 80 J = 1, N + DO 70 I = K, K + N - J + SUM = ABS( AP( I ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 70 CONTINUE + K = K + N - J + 1 + 80 CONTINUE + END IF + END IF + ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN +* +* Find norm1(A). +* + VALUE = ZERO + K = 1 + UDIAG = LSAME( DIAG, 'U' ) + IF( LSAME( UPLO, 'U' ) ) THEN + DO 110 J = 1, N + IF( UDIAG ) THEN + SUM = ONE + DO 90 I = K, K + J - 2 + SUM = SUM + ABS( AP( I ) ) + 90 CONTINUE + ELSE + SUM = ZERO + DO 100 I = K, K + J - 1 + SUM = SUM + ABS( AP( I ) ) + 100 CONTINUE + END IF + K = K + J + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 110 CONTINUE + ELSE + DO 140 J = 1, N + IF( UDIAG ) THEN + SUM = ONE + DO 120 I = K + 1, K + N - J + SUM = SUM + ABS( AP( I ) ) + 120 CONTINUE + ELSE + SUM = ZERO + DO 130 I = K, K + N - J + SUM = SUM + ABS( AP( I ) ) + 130 CONTINUE + END IF + K = K + N - J + 1 + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 140 CONTINUE + END IF + ELSE IF( LSAME( NORM, 'I' ) ) THEN +* +* Find normI(A). +* + K = 1 + IF( LSAME( UPLO, 'U' ) ) THEN + IF( LSAME( DIAG, 'U' ) ) THEN + DO 150 I = 1, N + WORK( I ) = ONE + 150 CONTINUE + DO 170 J = 1, N + DO 160 I = 1, J - 1 + WORK( I ) = WORK( I ) + ABS( AP( K ) ) + K = K + 1 + 160 CONTINUE + K = K + 1 + 170 CONTINUE + ELSE + DO 180 I = 1, N + WORK( I ) = ZERO + 180 CONTINUE + DO 200 J = 1, N + DO 190 I = 1, J + WORK( I ) = WORK( I ) + ABS( AP( K ) ) + K = K + 1 + 190 CONTINUE + 200 CONTINUE + END IF + ELSE + IF( LSAME( DIAG, 'U' ) ) THEN + DO 210 I = 1, N + WORK( I ) = ONE + 210 CONTINUE + DO 230 J = 1, N + K = K + 1 + DO 220 I = J + 1, N + WORK( I ) = WORK( I ) + ABS( AP( K ) ) + K = K + 1 + 220 CONTINUE + 230 CONTINUE + ELSE + DO 240 I = 1, N + WORK( I ) = ZERO + 240 CONTINUE + DO 260 J = 1, N + DO 250 I = J, N + WORK( I ) = WORK( I ) + ABS( AP( K ) ) + K = K + 1 + 250 CONTINUE + 260 CONTINUE + END IF + END IF + VALUE = ZERO + DO 270 I = 1, N + SUM = WORK( I ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 270 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 = N + K = 2 + DO 280 J = 2, N + CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM ) + K = K + J + 280 CONTINUE + ELSE + SCALE = ZERO + SUM = ONE + K = 1 + DO 290 J = 1, N + CALL DLASSQ( J, AP( K ), 1, SCALE, SUM ) + K = K + J + 290 CONTINUE + END IF + ELSE + IF( LSAME( DIAG, 'U' ) ) THEN + SCALE = ONE + SUM = N + K = 2 + DO 300 J = 1, N - 1 + CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM ) + K = K + N - J + 1 + 300 CONTINUE + ELSE + SCALE = ZERO + SUM = ONE + K = 1 + DO 310 J = 1, N + CALL DLASSQ( N-J+1, AP( K ), 1, SCALE, SUM ) + K = K + N - J + 1 + 310 CONTINUE + END IF + END IF + VALUE = SCALE*SQRT( SUM ) + END IF +* + DLANTP = VALUE + RETURN +* +* End of DLANTP +* + END diff --git a/math/lapack/src/main/fortran/dlantr.f b/math/lapack/src/main/fortran/dlantr.f new file mode 100644 index 0000000000..8585b2f689 --- /dev/null +++ b/math/lapack/src/main/fortran/dlantr.f @@ -0,0 +1,353 @@ +*> \brief \b DLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a trapezoidal or triangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, +* WORK ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, NORM, UPLO +* INTEGER LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +*> +*> \return DLANTR +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in DLANTR as described +*> above. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is 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. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the matrix A has unit diagonal. +*> = 'N': Non-unit diagonal +*> = 'U': Unit diagonal +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is 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. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(M,1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +*> where LWORK >= M when NORM = 'I'; otherwise, WORK is not +*> referenced. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, + $ WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, NORM, UPLO + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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, DISNAN + EXTERNAL LSAME, DISNAN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, 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 ) + SUM = ABS( A( I, J ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J + 1, M + SUM = ABS( A( I, J ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 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 ) + SUM = ABS( A( I, J ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1, N + DO 70 I = J, M + SUM = ABS( A( I, J ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 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 + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) 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 + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) 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 + SUM = WORK( I ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 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/math/lapack/src/main/fortran/dlanv2.f b/math/lapack/src/main/fortran/dlanv2.f new file mode 100644 index 0000000000..91fa14ff22 --- /dev/null +++ b/math/lapack/src/main/fortran/dlanv2.f @@ -0,0 +1,289 @@ +*> \brief \b DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION +*> On entry, the elements of the input matrix. +*> On exit, they are overwritten by the elements of the +*> standardised Schur form. +*> \endverbatim +*> +*> \param[out] RT1R +*> \verbatim +*> RT1R is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] RT1I +*> \verbatim +*> RT1I is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] RT2R +*> \verbatim +*> RT2R is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] RT2I +*> \verbatim +*> RT2I is DOUBLE PRECISION +*> The real and imaginary parts of the eigenvalues. If the +*> eigenvalues are a complex conjugate pair, RT1I > 0. +*> \endverbatim +*> +*> \param[out] CS +*> \verbatim +*> CS is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] SN +*> \verbatim +*> SN is DOUBLE PRECISION +*> Parameters of the rotation matrix. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlapll.f b/math/lapack/src/main/fortran/dlapll.f new file mode 100644 index 0000000000..e8fb73385a --- /dev/null +++ b/math/lapack/src/main/fortran/dlapll.f @@ -0,0 +1,165 @@ +*> \brief \b DLAPLL measures the linear dependence of two vectors. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAPLL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAPLL( N, X, INCX, Y, INCY, SSMIN ) +* +* .. Scalar Arguments .. +* INTEGER INCX, INCY, N +* DOUBLE PRECISION SSMIN +* .. +* .. Array Arguments .. +* DOUBLE PRECISION X( * ), Y( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Given two column vectors X and Y, let +*> +*> A = ( X Y ). +*> +*> The subroutine first computes the QR factorization of A = Q*R, +*> and then computes the SVD of the 2-by-2 upper triangular matrix R. +*> The smaller singular value of R is returned in SSMIN, which is used +*> as the measurement of the linear dependency of the vectors X and Y. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The length of the vectors X and Y. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, +*> dimension (1+(N-1)*INCX) +*> On entry, X contains the N-vector X. +*> On exit, X is overwritten. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The increment between successive elements of X. INCX > 0. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, +*> dimension (1+(N-1)*INCY) +*> On entry, Y contains the N-vector Y. +*> On exit, Y is overwritten. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> The increment between successive elements of Y. INCY > 0. +*> \endverbatim +*> +*> \param[out] SSMIN +*> \verbatim +*> SSMIN is DOUBLE PRECISION +*> The smallest singular value of the N-by-2 matrix A = ( X Y ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAPLL( N, X, INCX, Y, INCY, SSMIN ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCX, INCY, N + DOUBLE PRECISION SSMIN +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ), Y( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION A11, A12, A22, C, SSMAX, TAU +* .. +* .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DLARFG, DLAS2 +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.1 ) THEN + SSMIN = ZERO + RETURN + END IF +* +* Compute the QR factorization of the N-by-2 matrix ( X Y ) +* + CALL DLARFG( N, X( 1 ), X( 1+INCX ), INCX, TAU ) + A11 = X( 1 ) + X( 1 ) = ONE +* + C = -TAU*DDOT( N, X, INCX, Y, INCY ) + CALL DAXPY( N, C, X, INCX, Y, INCY ) +* + CALL DLARFG( N-1, Y( 1+INCY ), Y( 1+2*INCY ), INCY, TAU ) +* + A12 = Y( 1 ) + A22 = Y( 1+INCY ) +* +* Compute the SVD of 2-by-2 Upper triangular matrix. +* + CALL DLAS2( A11, A12, A22, SSMIN, SSMAX ) +* + RETURN +* +* End of DLAPLL +* + END diff --git a/math/lapack/src/main/fortran/dlapmr.f b/math/lapack/src/main/fortran/dlapmr.f new file mode 100644 index 0000000000..257eb61c76 --- /dev/null +++ b/math/lapack/src/main/fortran/dlapmr.f @@ -0,0 +1,204 @@ +*> \brief \b DLAPMR rearranges rows of a matrix as specified by a permutation vector. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAPMR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAPMR( FORWRD, M, N, X, LDX, K ) +* +* .. Scalar Arguments .. +* LOGICAL FORWRD +* INTEGER LDX, M, N +* .. +* .. Array Arguments .. +* INTEGER K( * ) +* DOUBLE PRECISION X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAPMR rearranges the rows of the M by N matrix X as specified +*> by the permutation K(1),K(2),...,K(M) of the integers 1,...,M. +*> If FORWRD = .TRUE., forward permutation: +*> +*> X(K(I),*) is moved X(I,*) for I = 1,2,...,M. +*> +*> If FORWRD = .FALSE., backward permutation: +*> +*> X(I,*) is moved to X(K(I),*) for I = 1,2,...,M. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FORWRD +*> \verbatim +*> FORWRD is LOGICAL +*> = .TRUE., forward permutation +*> = .FALSE., backward permutation +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix X. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix X. N >= 0. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,N) +*> On entry, the M by N matrix X. +*> On exit, X contains the permuted matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X, LDX >= MAX(1,M). +*> \endverbatim +*> +*> \param[in,out] K +*> \verbatim +*> K is INTEGER array, dimension (M) +*> On entry, K contains the permutation vector. K is used as +*> internal workspace, but reset to its original value on +*> output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAPMR( FORWRD, M, N, X, LDX, K ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + LOGICAL FORWRD + INTEGER LDX, M, N +* .. +* .. Array Arguments .. + INTEGER K( * ) + DOUBLE PRECISION X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IN, J, JJ + DOUBLE PRECISION TEMP +* .. +* .. Executable Statements .. +* + IF( M.LE.1 ) + $ RETURN +* + DO 10 I = 1, M + K( I ) = -K( I ) + 10 CONTINUE +* + IF( FORWRD ) THEN +* +* Forward permutation +* + DO 50 I = 1, M +* + 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 JJ = 1, N + TEMP = X( J, JJ ) + X( J, JJ ) = X( IN, JJ ) + X( IN, JJ ) = 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, M +* + 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 JJ = 1, N + TEMP = X( I, JJ ) + X( I, JJ ) = X( J, JJ ) + X( J, JJ ) = TEMP + 70 CONTINUE +* + K( J ) = -K( J ) + J = K( J ) + GO TO 60 +* + 80 CONTINUE +* + 90 CONTINUE +* + END IF +* + RETURN +* +* End of ZLAPMT +* + END + diff --git a/math/lapack/src/main/fortran/dlapmt.f b/math/lapack/src/main/fortran/dlapmt.f new file mode 100644 index 0000000000..b322e7ac52 --- /dev/null +++ b/math/lapack/src/main/fortran/dlapmt.f @@ -0,0 +1,203 @@ +*> \brief \b DLAPMT performs a forward or backward permutation of the columns of a matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAPMT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAPMT( FORWRD, M, N, X, LDX, K ) +* +* .. Scalar Arguments .. +* LOGICAL FORWRD +* INTEGER LDX, M, N +* .. +* .. Array Arguments .. +* INTEGER K( * ) +* DOUBLE PRECISION X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FORWRD +*> \verbatim +*> FORWRD is LOGICAL +*> = .TRUE., forward permutation +*> = .FALSE., backward permutation +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix X. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix X. N >= 0. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,N) +*> On entry, the M by N matrix X. +*> On exit, X contains the permuted matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X, LDX >= MAX(1,M). +*> \endverbatim +*> +*> \param[in,out] K +*> \verbatim +*> K is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAPMT( FORWRD, M, N, X, LDX, K ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + LOGICAL FORWRD + INTEGER LDX, M, N +* .. +* .. Array Arguments .. + INTEGER K( * ) + DOUBLE PRECISION X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlapy2.f b/math/lapack/src/main/fortran/dlapy2.f new file mode 100644 index 0000000000..3861b1d0a4 --- /dev/null +++ b/math/lapack/src/main/fortran/dlapy2.f @@ -0,0 +1,104 @@ +*> \brief \b DLAPY2 returns sqrt(x2+y2). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAPY2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION X, Y +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary +*> overflow. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is DOUBLE PRECISION +*> X and Y specify the values x and y. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, 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/math/lapack/src/main/fortran/dlapy3.f b/math/lapack/src/main/fortran/dlapy3.f new file mode 100644 index 0000000000..3bbba88875 --- /dev/null +++ b/math/lapack/src/main/fortran/dlapy3.f @@ -0,0 +1,111 @@ +*> \brief \b DLAPY3 returns sqrt(x2+y2+z2). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAPY3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION X, Y, Z +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause +*> unnecessary overflow. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION +*> X, Y and Z specify the values x, y and z. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y, 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/math/lapack/src/main/fortran/dlaqgb.f b/math/lapack/src/main/fortran/dlaqgb.f new file mode 100644 index 0000000000..3c9fac0d3f --- /dev/null +++ b/math/lapack/src/main/fortran/dlaqgb.f @@ -0,0 +1,256 @@ +*> \brief \b DLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQGB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, +* AMAX, EQUED ) +* +* .. Scalar Arguments .. +* CHARACTER EQUED +* INTEGER KL, KU, LDAB, M, N +* DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQGB equilibrates a general M by N band matrix A with KL +*> subdiagonals and KU superdiagonals using the row and scaling factors +*> in the vectors R and C. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The number of subdiagonals within the band of A. KL >= 0. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The number of superdiagonals within the band of A. KU >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the matrix A in band storage, in rows 1 to KL+KU+1. +*> The j-th column of A is stored in the j-th column of the +*> array AB as follows: +*> AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) +*> +*> On exit, the equilibrated matrix, in the same storage format +*> as A. See EQUED for the form of the equilibrated matrix. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDA >= KL+KU+1. +*> \endverbatim +*> +*> \param[in] R +*> \verbatim +*> R is DOUBLE PRECISION array, dimension (M) +*> The row scale factors for A. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> The column scale factors for A. +*> \endverbatim +*> +*> \param[in] ROWCND +*> \verbatim +*> ROWCND is DOUBLE PRECISION +*> Ratio of the smallest R(i) to the largest R(i). +*> \endverbatim +*> +*> \param[in] COLCND +*> \verbatim +*> COLCND is DOUBLE PRECISION +*> Ratio of the smallest C(i) to the largest C(i). +*> \endverbatim +*> +*> \param[in] AMAX +*> \verbatim +*> AMAX is DOUBLE PRECISION +*> Absolute value of largest matrix entry. +*> \endverbatim +*> +*> \param[out] EQUED +*> \verbatim +*> EQUED is 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). +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGBauxiliary +* +* ===================================================================== + SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, EQUED ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER EQUED + INTEGER KL, KU, LDAB, M, N + DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) +* .. +* +* ===================================================================== +* +* .. 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 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. 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 = MAX( 1, J-KU ), MIN( M, J+KL ) + AB( KU+1+I-J, J ) = CJ*AB( KU+1+I-J, 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 = MAX( 1, J-KU ), MIN( M, J+KL ) + AB( KU+1+I-J, J ) = R( I )*AB( KU+1+I-J, J ) + 30 CONTINUE + 40 CONTINUE + EQUED = 'R' + ELSE +* +* Row and column scaling +* + DO 60 J = 1, N + CJ = C( J ) + DO 50 I = MAX( 1, J-KU ), MIN( M, J+KL ) + AB( KU+1+I-J, J ) = CJ*R( I )*AB( KU+1+I-J, J ) + 50 CONTINUE + 60 CONTINUE + EQUED = 'B' + END IF +* + RETURN +* +* End of DLAQGB +* + END diff --git a/math/lapack/src/main/fortran/dlaqge.f b/math/lapack/src/main/fortran/dlaqge.f new file mode 100644 index 0000000000..a9852541a3 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaqge.f @@ -0,0 +1,236 @@ +*> \brief \b DLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, +* EQUED ) +* +* .. Scalar Arguments .. +* CHARACTER EQUED +* INTEGER LDA, M, N +* DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQGE equilibrates a general M by N matrix A using the row and +*> column scaling factors in the vectors R and C. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M by N matrix A. +*> On exit, the equilibrated matrix. See EQUED for the form of +*> the equilibrated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(M,1). +*> \endverbatim +*> +*> \param[in] R +*> \verbatim +*> R is DOUBLE PRECISION array, dimension (M) +*> The row scale factors for A. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (N) +*> The column scale factors for A. +*> \endverbatim +*> +*> \param[in] ROWCND +*> \verbatim +*> ROWCND is DOUBLE PRECISION +*> Ratio of the smallest R(i) to the largest R(i). +*> \endverbatim +*> +*> \param[in] COLCND +*> \verbatim +*> COLCND is DOUBLE PRECISION +*> Ratio of the smallest C(i) to the largest C(i). +*> \endverbatim +*> +*> \param[in] AMAX +*> \verbatim +*> AMAX is DOUBLE PRECISION +*> Absolute value of largest matrix entry. +*> \endverbatim +*> +*> \param[out] EQUED +*> \verbatim +*> EQUED is 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). +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEauxiliary +* +* ===================================================================== + SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ EQUED ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER EQUED + INTEGER LDA, M, N + DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlaqp2.f b/math/lapack/src/main/fortran/dlaqp2.f new file mode 100644 index 0000000000..b6351e04c9 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaqp2.f @@ -0,0 +1,262 @@ +*> \brief \b DLAQP2 computes a QR factorization with column pivoting of the matrix block. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQP2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, +* WORK ) +* +* .. Scalar Arguments .. +* INTEGER LDA, M, N, OFFSET +* .. +* .. Array Arguments .. +* INTEGER JPVT( * ) +* DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQP2 computes a QR factorization with column pivoting of +*> the block A(OFFSET+1:M,1:N). +*> The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] OFFSET +*> \verbatim +*> OFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but no factorized. OFFSET >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the upper triangle of block A(OFFSET+1:M,1:N) is +*> the triangular factor obtained; the elements in block +*> A(OFFSET+1:M,1:N) below the diagonal, together with the +*> array TAU, represent the orthogonal matrix Q as a product of +*> elementary reflectors. Block A(1:OFFSET,1:N) has been +*> accordingly pivoted, but no factorized. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] JPVT +*> \verbatim +*> JPVT is INTEGER array, dimension (N) +*> On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted +*> to the front of A*P (a leading column); if JPVT(i) = 0, +*> the i-th column of A is a free column. +*> On exit, if JPVT(i) = k, then the i-th column of A*P +*> was the k-th column of A. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is DOUBLE PRECISION array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is DOUBLE PRECISION array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain +*> X. Sun, Computer Science Dept., Duke University, USA +*> \n +*> Partial column norm updating strategy modified on April 2011 +*> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, +*> University of Zagreb, Croatia. +* +*> \par References: +* ================ +*> +*> LAPACK Working Note 176 +* +*> \htmlonly +*> [PDF] +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, + $ WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER LDA, M, N, OFFSET +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, MN, OFFPI, PVT + DOUBLE PRECISION 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)**T 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/math/lapack/src/main/fortran/dlaqps.f b/math/lapack/src/main/fortran/dlaqps.f new file mode 100644 index 0000000000..395d8e0b1a --- /dev/null +++ b/math/lapack/src/main/fortran/dlaqps.f @@ -0,0 +1,358 @@ +*> \brief \b DLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BLAS level 3. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQPS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, +* VN2, AUXV, F, LDF ) +* +* .. Scalar Arguments .. +* INTEGER KB, LDA, LDF, M, N, NB, OFFSET +* .. +* .. Array Arguments .. +* INTEGER JPVT( * ) +* DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), +* $ VN1( * ), VN2( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0 +*> \endverbatim +*> +*> \param[in] OFFSET +*> \verbatim +*> OFFSET is INTEGER +*> The number of rows of A that have been factorized in +*> previous steps. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The number of columns to factorize. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns actually factorized. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] JPVT +*> \verbatim +*> JPVT is INTEGER array, dimension (N) +*> JPVT(I) = K <==> Column K of the full matrix A has been +*> permuted into position I in AP. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (KB) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is DOUBLE PRECISION array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is DOUBLE PRECISION array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[in,out] AUXV +*> \verbatim +*> AUXV is DOUBLE PRECISION array, dimension (NB) +*> Auxiliar vector. +*> \endverbatim +*> +*> \param[in,out] F +*> \verbatim +*> F is DOUBLE PRECISION array, dimension (LDF,NB) +*> Matrix F**T = L*Y**T*A. +*> \endverbatim +*> +*> \param[in] LDF +*> \verbatim +*> LDF is INTEGER +*> The leading dimension of the array F. LDF >= max(1,N). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain +*> X. Sun, Computer Science Dept., Duke University, USA +*> \n +*> Partial column norm updating strategy modified on April 2011 +*> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, +*> University of Zagreb, Croatia. +* +*> \par References: +* ================ +*> +*> LAPACK Working Note 176 +* +*> \htmlonly +*> [PDF] +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, + $ VN2, AUXV, F, LDF ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER KB, LDA, LDF, M, N, NB, OFFSET +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), + $ VN1( * ), VN2( * ) +* .. +* +* ===================================================================== +* +* .. 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)**T. +* + 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)**T*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)**T +* *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)**T. +* + 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)**T. +* + 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/math/lapack/src/main/fortran/dlaqr0.f b/math/lapack/src/main/fortran/dlaqr0.f new file mode 100644 index 0000000000..247d4ef302 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaqr0.f @@ -0,0 +1,740 @@ +*> \brief \b DLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQR0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, +* ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* .. 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> = .TRUE. : the full Schur form T is required; +*> = .FALSE.: only eigenvalues are required. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> = .TRUE. : the matrix of Schur vectors Z is required; +*> = .FALSE.: Schur vectors are not required. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H. N .GE. 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is 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. +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is 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. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the array H. LDH .GE. max(1,N). +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array, dimension (IHI) +*> \endverbatim +*> +*> \param[out] WI +*> \verbatim +*> WI is DOUBLE PRECISION array, dimension (IHI) +*> The real and imaginary parts, respectively, of the computed +*> eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) +*> and WI(ILO:IHI). If two eigenvalues are computed as a +*> complex conjugate pair, they are stored in consecutive +*> elements of WR and WI, say the i-th and (i+1)th, with +*> WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then +*> the eigenvalues are stored in the same order as on the +*> diagonal of the Schur form returned in H, with +*> WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal +*> block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and +*> WI(i+1) = -WI(i). +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. +*> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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.) +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. if WANTZ is .TRUE. +*> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension LWORK +*> On exit, if LWORK = -1, WORK(1) returns an estimate of +*> the optimal value for LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +* +*> \par 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. +*> \n +*> 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. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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, * ) +* .. +* +* ================================================================ +* +* .. Parameters .. +* +* ==== Matrices of order NTINY or smaller must be processed by +* . DLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) +* +* ==== Exceptional deflation windows: try to cure rare +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + PARAMETER ( KEXNW = 5 ) +* +* ==== Exceptional shifts: try to cure rare slow convergence +* . with ad-hoc exceptional shifts every KEXSH iterations. +* . ==== + INTEGER KEXSH + PARAMETER ( KEXSH = 6 ) +* +* ==== The constants WILK1 and WILK2 are used to form the +* . exceptional shifts. ==== + DOUBLE PRECISION WILK1, WILK2 + PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) + DOUBLE PRECISION ZERO, ONE + 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, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, + $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD + LOGICAL 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 +* + IF( N.LE.NTINY ) THEN +* +* ==== Tiny matrices must use DLAHQR. ==== +* + 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 +* +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* +* ==== NWR = recommended deflation window size. At this +* . point, N .GT. NTINY = 11, so there is enough +* . subdiagonal workspace for NWR.GE.2 as required. +* . (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 ) +* +* ==== 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 ) + NW = NWMAX +* +* ==== 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: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== +* + NH = KBOT - KTOP + 1 + NWUPBD = MIN( NH, NWMAX ) + IF( NDFL.LT.KEXNW ) THEN + NW = MIN( NWUPBD, NWR ) + ELSE + NW = MIN( NWUPBD, 2*NW ) + END IF + 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 + IF( NDFL.LT.KEXNW ) THEN + NDEC = -1 + ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN + NDEC = NDEC + 1 + IF( NW-NDEC.LT.2 ) + $ NDEC = 0 + NW = NW - NDEC + END IF +* +* ==== Aggressive early deflation: +* . split workspace under the subdiagonal into +* . - 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/math/lapack/src/main/fortran/dlaqr1.f b/math/lapack/src/main/fortran/dlaqr1.f new file mode 100644 index 0000000000..acaefdeba0 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaqr1.f @@ -0,0 +1,179 @@ +*> \brief \b DLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQR1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION SI1, SI2, SR1, SR2 +* INTEGER LDH, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION H( LDH, * ), V( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is integer +*> Order of the matrix H. N must be either 2 or 3. +*> \endverbatim +*> +*> \param[in] H +*> \verbatim +*> H is DOUBLE PRECISION array of dimension (LDH,N) +*> The 2-by-2 or 3-by-3 matrix H in (*). +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is integer +*> The leading dimension of H as declared in +*> the calling procedure. LDH.GE.N +*> \endverbatim +*> +*> \param[in] SR1 +*> \verbatim +*> SR1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] SI1 +*> \verbatim +*> SI1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] SR2 +*> \verbatim +*> SR2 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] SI2 +*> \verbatim +*> SI2 is DOUBLE PRECISION +*> The shifts in (*). +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array of dimension N +*> A scalar multiple of the first column of the +*> matrix K in (*). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +*> +* ===================================================================== + SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION SI1, SI2, SR1, SR2 + INTEGER LDH, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), V( * ) +* .. +* +* ================================================================ +* +* .. 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/math/lapack/src/main/fortran/dlaqr2.f b/math/lapack/src/main/fortran/dlaqr2.f new file mode 100644 index 0000000000..910fdda68d --- /dev/null +++ b/math/lapack/src/main/fortran/dlaqr2.f @@ -0,0 +1,684 @@ +*> \brief \b DLAQR2 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, +* IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, +* LDT, NV, WV, LDWV, WORK, LWORK ) +* +* .. Scalar Arguments .. +* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, +* $ LDZ, LWORK, N, ND, NH, NS, NV, NW +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), +* $ V( LDV, * ), WORK( * ), WV( LDWV, * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQR2 is identical to DLAQR3 except that it avoids +*> recursion by calling DLAHQR instead of DLAQR4. +*> +*> Aggressive early deflation: +*> +*> This subroutine accepts as input an upper Hessenberg matrix +*> H and performs an orthogonal similarity transformation +*> designed to detect and deflate fully converged eigenvalues from +*> a trailing principal submatrix. On output H has been over- +*> written by a new Hessenberg matrix that is a perturbation of +*> an orthogonal similarity transformation of H. It is to be +*> hoped that the final version of H has many zero subdiagonal +*> entries. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> If .TRUE., then the Hessenberg matrix H is fully updated +*> so that the quasi-triangular Schur factor may be +*> computed (in cooperation with the calling subroutine). +*> If .FALSE., then only enough of H is updated to preserve +*> the eigenvalues. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> If .TRUE., then the orthogonal matrix Z is updated so +*> so that the orthogonal Schur factor may be computed +*> (in cooperation with the calling subroutine). +*> If .FALSE., then Z is not referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H and (if WANTZ is .TRUE.) the +*> order of the orthogonal matrix Z. +*> \endverbatim +*> +*> \param[in] KTOP +*> \verbatim +*> KTOP is INTEGER +*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +*> KBOT and KTOP together determine an isolated block +*> along the diagonal of the Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] KBOT +*> \verbatim +*> KBOT is INTEGER +*> It is assumed without a check that either +*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +*> determine an isolated block along the diagonal of the +*> Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] NW +*> \verbatim +*> NW is INTEGER +*> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is DOUBLE PRECISION array, dimension (LDH,N) +*> On input the initial N-by-N section of H stores the +*> Hessenberg matrix undergoing aggressive early deflation. +*> On output H has been transformed by an orthogonal +*> similarity transformation, perturbed, and the returned +*> to Hessenberg form that (it is to be hoped) has some +*> zero subdiagonal entries. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is integer +*> Leading dimension of H just as declared in the calling +*> subroutine. N .LE. LDH +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ,N) +*> IF WANTZ is .TRUE., then on output, the orthogonal +*> similarity transformation mentioned above has been +*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. +*> If WANTZ is .FALSE., then Z is unreferenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is integer +*> The leading dimension of Z just as declared in the +*> calling subroutine. 1 .LE. LDZ. +*> \endverbatim +*> +*> \param[out] NS +*> \verbatim +*> NS is integer +*> The number of unconverged (ie approximate) eigenvalues +*> returned in SR and SI that may be used as shifts by the +*> calling subroutine. +*> \endverbatim +*> +*> \param[out] ND +*> \verbatim +*> ND is integer +*> The number of converged eigenvalues uncovered by this +*> subroutine. +*> \endverbatim +*> +*> \param[out] SR +*> \verbatim +*> SR is DOUBLE PRECISION array, dimension (KBOT) +*> \endverbatim +*> +*> \param[out] SI +*> \verbatim +*> SI is DOUBLE PRECISION array, dimension (KBOT) +*> On output, the real and imaginary parts of approximate +*> eigenvalues that may be used for shifts are stored in +*> SR(KBOT-ND-NS+1) through SR(KBOT-ND) and +*> SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. +*> The real and imaginary parts of converged eigenvalues +*> are stored in SR(KBOT-ND+1) through SR(KBOT) and +*> SI(KBOT-ND+1) through SI(KBOT), respectively. +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,NW) +*> An NW-by-NW work array. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is integer scalar +*> The leading dimension of V just as declared in the +*> calling subroutine. NW .LE. LDV +*> \endverbatim +*> +*> \param[in] NH +*> \verbatim +*> NH is integer scalar +*> The number of columns of T. NH.GE.NW. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,NW) +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is integer +*> The leading dimension of T just as declared in the +*> calling subroutine. NW .LE. LDT +*> \endverbatim +*> +*> \param[in] NV +*> \verbatim +*> NV is integer +*> The number of rows of work array WV available for +*> workspace. NV.GE.NW. +*> \endverbatim +*> +*> \param[out] WV +*> \verbatim +*> WV is DOUBLE PRECISION array, dimension (LDWV,NW) +*> \endverbatim +*> +*> \param[in] LDWV +*> \verbatim +*> LDWV is integer +*> The leading dimension of W just as declared in the +*> calling subroutine. NW .LE. LDV +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> On exit, WORK(1) is set to an estimate of the optimal value +*> of LWORK for the given values of N, NW, KTOP and KBOT. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is integer +*> The dimension of the work array WORK. LWORK = 2*NW +*> suffices, but greater efficiency may result from larger +*> values of LWORK. +*> +*> If LWORK = -1, then a workspace query is assumed; DLAQR2 +*> only estimates the optimal workspace size for the given +*> values of N, NW, KTOP and KBOT. The estimate is returned +*> in WORK(1). No error message related to LWORK is issued +*> by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +*> +* ===================================================================== + SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, + $ LDT, NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), + $ V( LDV, * ), WORK( * ), WV( LDWV, * ), + $ Z( LDZ, * ) +* .. +* +* ================================================================ +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, + $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, + $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, + $ LWKOPT + LOGICAL BULGE, SORTED +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, + $ DLANV2, DLARF, DLARFG, DLASET, DORMHR, DTREXC +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to DGEHRD ==== +* + CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to DORMHR ==== +* + CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + $ WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = JW + MAX( LWK1, LWK2 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + WORK( 1 ) = ONE + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + 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 + WORK( 1 ) = ONE + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) +* + CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) +* +* ==== DTREXC needs a clean margin near the diagonal ==== +* + DO 10 J = 1, JW - 3 + T( J+2, J ) = ZERO + T( J+3, J ) = ZERO + 10 CONTINUE + IF( JW.GT.2 ) + $ T( JW, JW-2 ) = ZERO +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + 20 CONTINUE + IF( ILST.LE.NS ) THEN + IF( NS.EQ.1 ) THEN + BULGE = .FALSE. + ELSE + BULGE = T( NS, NS-1 ).NE.ZERO + END IF +* +* ==== Small spike tip test for deflation ==== +* + IF( .NOT.BULGE ) THEN +* +* ==== Real eigenvalue ==== +* + FOO = ABS( T( NS, NS ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 1 + ELSE +* +* ==== Undeflatable. Move it up out of the way. +* . (DTREXC can not fail in this case.) ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 1 + END IF + ELSE +* +* ==== Complex conjugate pair ==== +* + FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* + $ SQRT( ABS( T( NS-1, NS ) ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. + $ MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 2 + ELSE +* +* ==== Undeflatable. Move them up out of the way. +* . Fortunately, DTREXC does the right thing with +* . ILST in case of a rare exchange failure. ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 2 + END IF + END IF +* +* ==== End deflation detection loop ==== +* + GO TO 20 + END IF +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting diagonal blocks of T improves accuracy for +* . graded matrices. Bubble sort deals well with +* . exchange failures. ==== +* + SORTED = .false. + I = NS + 1 + 30 CONTINUE + IF( SORTED ) + $ GO TO 50 + SORTED = .true. +* + KEND = I - 1 + I = INFQR + 1 + IF( I.EQ.NS ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + 40 CONTINUE + IF( K.LE.KEND ) THEN + IF( K.EQ.I+1 ) THEN + EVI = ABS( T( I, I ) ) + ELSE + EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* + $ SQRT( ABS( T( I, I+1 ) ) ) + END IF +* + IF( K.EQ.KEND ) THEN + EVK = ABS( T( K, K ) ) + ELSE IF( T( K+1, K ).EQ.ZERO ) THEN + EVK = ABS( T( K, K ) ) + ELSE + EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* + $ SQRT( ABS( T( K, K+1 ) ) ) + END IF +* + IF( EVI.GE.EVK ) THEN + I = K + ELSE + SORTED = .false. + IFST = I + ILST = K + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + IF( INFO.EQ.0 ) THEN + I = ILST + ELSE + I = K + END IF + END IF + IF( I.EQ.KEND ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + GO TO 40 + END IF + GO TO 30 + 50 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + I = JW + 60 CONTINUE + IF( I.GE.INFQR+1 ) THEN + IF( I.EQ.INFQR+1 ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE + AA = T( I-1, I-1 ) + CC = T( I, I-1 ) + BB = T( I-1, I ) + DD = T( I, I ) + CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), + $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), + $ SI( KWTOP+I-1 ), CS, SN ) + I = I - 2 + END IF + GO TO 60 + END IF +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL DCOPY( NS, V, LDV, WORK, 1 ) + BETA = WORK( 1 ) + CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + 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. ==== +* + IF( NS.GT.1 .AND. S.NE.ZERO ) + $ CALL DORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ WORK( JW+1 ), LWORK-JW, INFO ) +* +* ==== Update vertical slab in H ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 70 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 70 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 80 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 80 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 90 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 90 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* ==== End of DLAQR2 ==== +* + END diff --git a/math/lapack/src/main/fortran/dlaqr3.f b/math/lapack/src/main/fortran/dlaqr3.f new file mode 100644 index 0000000000..8a668bc650 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaqr3.f @@ -0,0 +1,695 @@ +*> \brief \b DLAQR3 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQR3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, +* IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, +* LDT, NV, WV, LDWV, WORK, LWORK ) +* +* .. Scalar Arguments .. +* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, +* $ LDZ, LWORK, N, ND, NH, NS, NV, NW +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), +* $ V( LDV, * ), WORK( * ), WV( LDWV, * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Aggressive early deflation: +*> +*> DLAQR3 accepts as input an upper Hessenberg matrix +*> H and performs an orthogonal similarity transformation +*> designed to detect and deflate fully converged eigenvalues from +*> a trailing principal submatrix. On output H has been over- +*> written by a new Hessenberg matrix that is a perturbation of +*> an orthogonal similarity transformation of H. It is to be +*> hoped that the final version of H has many zero subdiagonal +*> entries. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> If .TRUE., then the Hessenberg matrix H is fully updated +*> so that the quasi-triangular Schur factor may be +*> computed (in cooperation with the calling subroutine). +*> If .FALSE., then only enough of H is updated to preserve +*> the eigenvalues. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> If .TRUE., then the orthogonal matrix Z is updated so +*> so that the orthogonal Schur factor may be computed +*> (in cooperation with the calling subroutine). +*> If .FALSE., then Z is not referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H and (if WANTZ is .TRUE.) the +*> order of the orthogonal matrix Z. +*> \endverbatim +*> +*> \param[in] KTOP +*> \verbatim +*> KTOP is INTEGER +*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +*> KBOT and KTOP together determine an isolated block +*> along the diagonal of the Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] KBOT +*> \verbatim +*> KBOT is INTEGER +*> It is assumed without a check that either +*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +*> determine an isolated block along the diagonal of the +*> Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] NW +*> \verbatim +*> NW is INTEGER +*> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is DOUBLE PRECISION array, dimension (LDH,N) +*> On input the initial N-by-N section of H stores the +*> Hessenberg matrix undergoing aggressive early deflation. +*> On output H has been transformed by an orthogonal +*> similarity transformation, perturbed, and the returned +*> to Hessenberg form that (it is to be hoped) has some +*> zero subdiagonal entries. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is integer +*> Leading dimension of H just as declared in the calling +*> subroutine. N .LE. LDH +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ,N) +*> IF WANTZ is .TRUE., then on output, the orthogonal +*> similarity transformation mentioned above has been +*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. +*> If WANTZ is .FALSE., then Z is unreferenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is integer +*> The leading dimension of Z just as declared in the +*> calling subroutine. 1 .LE. LDZ. +*> \endverbatim +*> +*> \param[out] NS +*> \verbatim +*> NS is integer +*> The number of unconverged (ie approximate) eigenvalues +*> returned in SR and SI that may be used as shifts by the +*> calling subroutine. +*> \endverbatim +*> +*> \param[out] ND +*> \verbatim +*> ND is integer +*> The number of converged eigenvalues uncovered by this +*> subroutine. +*> \endverbatim +*> +*> \param[out] SR +*> \verbatim +*> SR is DOUBLE PRECISION array, dimension (KBOT) +*> \endverbatim +*> +*> \param[out] SI +*> \verbatim +*> SI is DOUBLE PRECISION array, dimension (KBOT) +*> On output, the real and imaginary parts of approximate +*> eigenvalues that may be used for shifts are stored in +*> SR(KBOT-ND-NS+1) through SR(KBOT-ND) and +*> SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. +*> The real and imaginary parts of converged eigenvalues +*> are stored in SR(KBOT-ND+1) through SR(KBOT) and +*> SI(KBOT-ND+1) through SI(KBOT), respectively. +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,NW) +*> An NW-by-NW work array. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is integer scalar +*> The leading dimension of V just as declared in the +*> calling subroutine. NW .LE. LDV +*> \endverbatim +*> +*> \param[in] NH +*> \verbatim +*> NH is integer scalar +*> The number of columns of T. NH.GE.NW. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,NW) +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is integer +*> The leading dimension of T just as declared in the +*> calling subroutine. NW .LE. LDT +*> \endverbatim +*> +*> \param[in] NV +*> \verbatim +*> NV is integer +*> The number of rows of work array WV available for +*> workspace. NV.GE.NW. +*> \endverbatim +*> +*> \param[out] WV +*> \verbatim +*> WV is DOUBLE PRECISION array, dimension (LDWV,NW) +*> \endverbatim +*> +*> \param[in] LDWV +*> \verbatim +*> LDWV is integer +*> The leading dimension of W just as declared in the +*> calling subroutine. NW .LE. LDV +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> On exit, WORK(1) is set to an estimate of the optimal value +*> of LWORK for the given values of N, NW, KTOP and KBOT. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is integer +*> The dimension of the work array WORK. LWORK = 2*NW +*> suffices, but greater efficiency may result from larger +*> values of LWORK. +*> +*> If LWORK = -1, then a workspace query is assumed; DLAQR3 +*> only estimates the optimal workspace size for the given +*> values of N, NW, KTOP and KBOT. The estimate is returned +*> in WORK(1). No error message related to LWORK is issued +*> by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +*> +* ===================================================================== + SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, + $ LDT, NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), + $ V( LDV, * ), WORK( * ), WV( LDWV, * ), + $ Z( LDZ, * ) +* .. +* +* ================================================================ +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, + $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, + $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, + $ LWKOPT, NMIN + LOGICAL BULGE, SORTED +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + EXTERNAL DLAMCH, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, + $ DLANV2, DLAQR4, DLARF, DLARFG, DLASET, DORMHR, + $ DTREXC +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to DGEHRD ==== +* + CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to DORMHR ==== +* + CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + $ WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to DLAQR4 ==== +* + CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW, + $ V, LDV, WORK, -1, INFQR ) + LWK3 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + WORK( 1 ) = ONE + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + 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 + WORK( 1 ) = ONE + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) +* + CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + NMIN = ILAENV( 12, 'DLAQR3', 'SV', JW, 1, JW, LWORK ) + IF( JW.GT.NMIN ) THEN + CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR ) + ELSE + CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) + END IF +* +* ==== DTREXC needs a clean margin near the diagonal ==== +* + DO 10 J = 1, JW - 3 + T( J+2, J ) = ZERO + T( J+3, J ) = ZERO + 10 CONTINUE + IF( JW.GT.2 ) + $ T( JW, JW-2 ) = ZERO +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + 20 CONTINUE + IF( ILST.LE.NS ) THEN + IF( NS.EQ.1 ) THEN + BULGE = .FALSE. + ELSE + BULGE = T( NS, NS-1 ).NE.ZERO + END IF +* +* ==== Small spike tip test for deflation ==== +* + IF( .NOT. BULGE ) THEN +* +* ==== Real eigenvalue ==== +* + FOO = ABS( T( NS, NS ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 1 + ELSE +* +* ==== Undeflatable. Move it up out of the way. +* . (DTREXC can not fail in this case.) ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 1 + END IF + ELSE +* +* ==== Complex conjugate pair ==== +* + FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* + $ SQRT( ABS( T( NS-1, NS ) ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. + $ MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 2 + ELSE +* +* ==== Undeflatable. Move them up out of the way. +* . Fortunately, DTREXC does the right thing with +* . ILST in case of a rare exchange failure. ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 2 + END IF + END IF +* +* ==== End deflation detection loop ==== +* + GO TO 20 + END IF +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting diagonal blocks of T improves accuracy for +* . graded matrices. Bubble sort deals well with +* . exchange failures. ==== +* + SORTED = .false. + I = NS + 1 + 30 CONTINUE + IF( SORTED ) + $ GO TO 50 + SORTED = .true. +* + KEND = I - 1 + I = INFQR + 1 + IF( I.EQ.NS ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + 40 CONTINUE + IF( K.LE.KEND ) THEN + IF( K.EQ.I+1 ) THEN + EVI = ABS( T( I, I ) ) + ELSE + EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* + $ SQRT( ABS( T( I, I+1 ) ) ) + END IF +* + IF( K.EQ.KEND ) THEN + EVK = ABS( T( K, K ) ) + ELSE IF( T( K+1, K ).EQ.ZERO ) THEN + EVK = ABS( T( K, K ) ) + ELSE + EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* + $ SQRT( ABS( T( K, K+1 ) ) ) + END IF +* + IF( EVI.GE.EVK ) THEN + I = K + ELSE + SORTED = .false. + IFST = I + ILST = K + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + IF( INFO.EQ.0 ) THEN + I = ILST + ELSE + I = K + END IF + END IF + IF( I.EQ.KEND ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + GO TO 40 + END IF + GO TO 30 + 50 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + I = JW + 60 CONTINUE + IF( I.GE.INFQR+1 ) THEN + IF( I.EQ.INFQR+1 ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE + AA = T( I-1, I-1 ) + CC = T( I, I-1 ) + BB = T( I-1, I ) + DD = T( I, I ) + CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), + $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), + $ SI( KWTOP+I-1 ), CS, SN ) + I = I - 2 + END IF + GO TO 60 + END IF +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL DCOPY( NS, V, LDV, WORK, 1 ) + BETA = WORK( 1 ) + CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + 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. ==== +* + IF( NS.GT.1 .AND. S.NE.ZERO ) + $ CALL DORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ WORK( JW+1 ), LWORK-JW, INFO ) +* +* ==== Update vertical slab in H ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 70 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 70 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 80 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 80 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 90 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 90 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* ==== End of DLAQR3 ==== +* + END diff --git a/math/lapack/src/main/fortran/dlaqr4.f b/math/lapack/src/main/fortran/dlaqr4.f new file mode 100644 index 0000000000..89b9b7f209 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaqr4.f @@ -0,0 +1,739 @@ +*> \brief \b DLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQR4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, +* ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* .. 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQR4 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. +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> = .TRUE. : the full Schur form T is required; +*> = .FALSE.: only eigenvalues are required. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> = .TRUE. : the matrix of Schur vectors Z is required; +*> = .FALSE.: Schur vectors are not required. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H. N .GE. 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is 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. +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is 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. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the array H. LDH .GE. max(1,N). +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array, dimension (IHI) +*> \endverbatim +*> +*> \param[out] WI +*> \verbatim +*> WI is DOUBLE PRECISION array, dimension (IHI) +*> The real and imaginary parts, respectively, of the computed +*> eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) +*> and WI(ILO:IHI). If two eigenvalues are computed as a +*> complex conjugate pair, they are stored in consecutive +*> elements of WR and WI, say the i-th and (i+1)th, with +*> WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then +*> the eigenvalues are stored in the same order as on the +*> diagonal of the Schur form returned in H, with +*> WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal +*> block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and +*> WI(i+1) = -WI(i). +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. +*> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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.) +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. if WANTZ is .TRUE. +*> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension LWORK +*> On exit, if LWORK = -1, WORK(1) returns an estimate of +*> the optimal value for LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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 a orthogonal 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 orthogonal matrix in (*) (regard- +*> less of the value of WANTT.) +*> +*> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not +*> accessed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +* +*> \par 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. +*> \n +*> 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. +*> +* ===================================================================== + SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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, * ) +* .. +* +* ================================================================ +* .. Parameters .. +* +* ==== Matrices of order NTINY or smaller must be processed by +* . DLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) +* +* ==== Exceptional deflation windows: try to cure rare +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + PARAMETER ( KEXNW = 5 ) +* +* ==== Exceptional shifts: try to cure rare slow convergence +* . with ad-hoc exceptional shifts every KEXSH iterations. +* . ==== + INTEGER KEXSH + PARAMETER ( KEXSH = 6 ) +* +* ==== The constants WILK1 and WILK2 are used to form the +* . exceptional shifts. ==== + DOUBLE PRECISION WILK1, WILK2 + PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) + DOUBLE PRECISION ZERO, ONE + 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, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, + $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD + LOGICAL 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 +* + IF( N.LE.NTINY ) THEN +* +* ==== Tiny matrices must use DLAHQR. ==== +* + 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 +* +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* +* ==== NWR = recommended deflation window size. At this +* . point, N .GT. NTINY = 11, so there is enough +* . subdiagonal workspace for NWR.GE.2 as required. +* . (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 ) +* +* ==== 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 ) + NW = NWMAX +* +* ==== 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: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== +* + NH = KBOT - KTOP + 1 + NWUPBD = MIN( NH, NWMAX ) + IF( NDFL.LT.KEXNW ) THEN + NW = MIN( NWUPBD, NWR ) + ELSE + NW = MIN( NWUPBD, 2*NW ) + END IF + 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 + IF( NDFL.LT.KEXNW ) THEN + NDEC = -1 + ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN + NDEC = NDEC + 1 + IF( NW-NDEC.LT.2 ) + $ NDEC = 0 + NW = NW - NDEC + END IF +* +* ==== Aggressive early deflation: +* . split workspace under the subdiagonal into +* . - 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/math/lapack/src/main/fortran/dlaqr5.f b/math/lapack/src/main/fortran/dlaqr5.f new file mode 100644 index 0000000000..8b536c08ca --- /dev/null +++ b/math/lapack/src/main/fortran/dlaqr5.f @@ -0,0 +1,921 @@ +*> \brief \b DLAQR5 performs a single small-bulge multi-shift QR sweep. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQR5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* 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 ) +* +* .. 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQR5, called by DLAQR0, performs a +*> single small-bulge multi-shift QR sweep. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is logical scalar +*> WANTT = .true. if the quasi-triangular Schur factor +*> is being computed. WANTT is set to .false. otherwise. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is logical scalar +*> WANTZ = .true. if the orthogonal Schur factor is being +*> computed. WANTZ is set to .false. otherwise. +*> \endverbatim +*> +*> \param[in] KACC22 +*> \verbatim +*> KACC22 is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is integer scalar +*> N is the order of the Hessenberg matrix H upon which this +*> subroutine operates. +*> \endverbatim +*> +*> \param[in] KTOP +*> \verbatim +*> KTOP is integer scalar +*> \endverbatim +*> +*> \param[in] KBOT +*> \verbatim +*> KBOT is 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. +*> \endverbatim +*> +*> \param[in] NSHFTS +*> \verbatim +*> NSHFTS is integer scalar +*> NSHFTS gives the number of simultaneous shifts. NSHFTS +*> must be positive and even. +*> \endverbatim +*> +*> \param[in,out] SR +*> \verbatim +*> SR is DOUBLE PRECISION array of size (NSHFTS) +*> \endverbatim +*> +*> \param[in,out] SI +*> \verbatim +*> SI is DOUBLE PRECISION array of size (NSHFTS) +*> SR contains the real parts and SI contains the imaginary +*> parts of the NSHFTS shifts of origin that define the +*> multi-shift QR sweep. On output SR and SI may be +*> reordered. +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is 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. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is integer scalar +*> LDH is the leading dimension of H just as declared in the +*> calling procedure. LDH.GE.MAX(1,N). +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array of size (LDZ,IHIZ) +*> If WANTZ = .TRUE., then the QR Sweep orthogonal +*> similarity transformation is accumulated into +*> Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. +*> If WANTZ = .FALSE., then Z is unreferenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is integer scalar +*> LDA is the leading dimension of Z just as declared in +*> the calling procedure. LDZ.GE.N. +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array of size (LDV,NSHFTS/2) +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is integer scalar +*> LDV is the leading dimension of V as declared in the +*> calling procedure. LDV.GE.3. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is DOUBLE PRECISION array of size +*> (LDU,3*NSHFTS-3) +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is integer scalar +*> LDU is the leading dimension of U just as declared in the +*> in the calling subroutine. LDU.GE.3*NSHFTS-3. +*> \endverbatim +*> +*> \param[in] NH +*> \verbatim +*> NH is integer scalar +*> NH is the number of columns in array WH available for +*> workspace. NH.GE.1. +*> \endverbatim +*> +*> \param[out] WH +*> \verbatim +*> WH is DOUBLE PRECISION array of size (LDWH,NH) +*> \endverbatim +*> +*> \param[in] LDWH +*> \verbatim +*> LDWH is integer scalar +*> Leading dimension of WH just as declared in the +*> calling procedure. LDWH.GE.3*NSHFTS-3. +*> \endverbatim +*> +*> \param[in] NV +*> \verbatim +*> NV is integer scalar +*> NV is the number of rows in WV agailable for workspace. +*> NV.GE.1. +*> \endverbatim +*> +*> \param[out] WV +*> \verbatim +*> WV is DOUBLE PRECISION array of size +*> (LDWV,3*NSHFTS-3) +*> \endverbatim +*> +*> \param[in] LDWV +*> \verbatim +*> LDWV is integer scalar +*> LDWV is the leading dimension of WV as declared in the +*> in the calling subroutine. LDWV.GE.NV. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +* +*> \par 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. +*> +* ===================================================================== + 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.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. 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, * ) +* .. +* +* ================================================================ +* .. 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 it is odd, +* . then simply reduce it by one. The shuffle above +* . ensures that the dropped shift is real and that +* . the remaining shifts are paired. ==== +* + NS = NSHFTS - 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. In the +* . underflow case, try the two-small-subdiagonals +* . trick to try to reinflate the bulge. ==== +* + IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE. + $ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN +* +* ==== Typical case: not collapsed (yet). ==== +* + 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) and H(K+2,K). +* . If the fill resulting from the new +* . reflector is too large, then abandon it. +* . Otherwise, use the new one. ==== +* + CALL DLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ), + $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), + $ VT ) + ALPHA = VT( 1 ) + CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) + REFSUM = VT( 1 )*( H( K+1, K )+VT( 2 )* + $ H( K+2, K ) ) +* + IF( ABS( H( K+2, K )-REFSUM*VT( 2 ) )+ + $ ABS( REFSUM*VT( 3 ) ).GT.ULP* + $ ( ABS( H( K, K ) )+ABS( H( K+1, + $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN +* +* ==== Starting a new bulge here would +* . create non-negligible fill. Use +* . the old one with trepidation. ==== +* + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + ELSE +* +* ==== Stating a new bulge here would +* . create only negligible fill. +* . Replace the old reflector with +* . the new one. ==== +* + H( K+1, K ) = H( K+1, K ) - 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 + 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 ) THEN + IF ( 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 + 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**T ==== +* + 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**T ==== +* + CALL DGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, + $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) +* +* ==== Copy top of H to bottom of WH ==== +* + CALL DLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, + $ WH( I2+1, 1 ), LDWH ) +* +* ==== Multiply by U21**T ==== +* + 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/math/lapack/src/main/fortran/dlaqsb.f b/math/lapack/src/main/fortran/dlaqsb.f new file mode 100644 index 0000000000..3a6ef70aa3 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaqsb.f @@ -0,0 +1,226 @@ +*> \brief \b DLAQSB scales a symmetric/Hermitian band matrix, using scaling factors computed by spbequ. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQSB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) +* +* .. Scalar Arguments .. +* CHARACTER EQUED, UPLO +* INTEGER KD, LDAB, N +* DOUBLE PRECISION AMAX, SCOND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), S( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQSB equilibrates a symmetric band matrix A using the scaling +*> factors in the vector S. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of super-diagonals of the matrix A if UPLO = 'U', +*> or the number of sub-diagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, if INFO = 0, the triangular factor U or L from the +*> Cholesky factorization A = U**T*U or A = L*L**T of the band +*> matrix A, in the same storage format as A. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N) +*> The scale factors for A. +*> \endverbatim +*> +*> \param[in] SCOND +*> \verbatim +*> SCOND is DOUBLE PRECISION +*> Ratio of the smallest S(i) to the largest S(i). +*> \endverbatim +*> +*> \param[in] AMAX +*> \verbatim +*> AMAX is DOUBLE PRECISION +*> Absolute value of largest matrix entry. +*> \endverbatim +*> +*> \param[out] EQUED +*> \verbatim +*> EQUED is CHARACTER*1 +*> Specifies whether or not equilibration was done. +*> = 'N': No equilibration. +*> = 'Y': Equilibration was done, i.e., A has been replaced by +*> diag(S) * A * diag(S). +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> THRESH is a threshold value used to decide if scaling should be done +*> based on the ratio of the scaling factors. If SCOND < THRESH, +*> scaling is done. +*> +*> LARGE and SMALL are threshold values used to decide if scaling should +*> be done based on the absolute size of the largest matrix element. +*> If AMAX > LARGE or AMAX < SMALL, scaling is done. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER EQUED, UPLO + INTEGER KD, LDAB, N + DOUBLE PRECISION AMAX, SCOND +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), S( * ) +* .. +* +* ===================================================================== +* +* .. 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 .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + EQUED = 'N' + RETURN + END IF +* +* Initialize LARGE and SMALL. +* + SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + LARGE = ONE / SMALL +* + IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN +* +* No equilibration +* + EQUED = 'N' + ELSE +* +* Replace A by diag(S) * A * diag(S). +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Upper triangle of A is stored in band format. +* + DO 20 J = 1, N + CJ = S( J ) + DO 10 I = MAX( 1, J-KD ), J + AB( KD+1+I-J, J ) = CJ*S( I )*AB( KD+1+I-J, J ) + 10 CONTINUE + 20 CONTINUE + ELSE +* +* Lower triangle of A is stored. +* + DO 40 J = 1, N + CJ = S( J ) + DO 30 I = J, MIN( N, J+KD ) + AB( 1+I-J, J ) = CJ*S( I )*AB( 1+I-J, J ) + 30 CONTINUE + 40 CONTINUE + END IF + EQUED = 'Y' + END IF +* + RETURN +* +* End of DLAQSB +* + END diff --git a/math/lapack/src/main/fortran/dlaqsp.f b/math/lapack/src/main/fortran/dlaqsp.f new file mode 100644 index 0000000000..5f25d1e303 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaqsp.f @@ -0,0 +1,212 @@ +*> \brief \b DLAQSP scales a symmetric/Hermitian matrix in packed storage, using scaling factors computed by sppequ. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQSP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) +* +* .. Scalar Arguments .. +* CHARACTER EQUED, UPLO +* INTEGER N +* DOUBLE PRECISION AMAX, SCOND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ), S( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQSP equilibrates a symmetric matrix A using the scaling factors +*> in the vector S. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> On entry, the upper or lower triangle of the symmetric matrix +*> A, packed columnwise in a linear array. The j-th column of A +*> is stored in the array AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +*> +*> On exit, the equilibrated matrix: diag(S) * A * diag(S), in +*> the same storage format as A. +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N) +*> The scale factors for A. +*> \endverbatim +*> +*> \param[in] SCOND +*> \verbatim +*> SCOND is DOUBLE PRECISION +*> Ratio of the smallest S(i) to the largest S(i). +*> \endverbatim +*> +*> \param[in] AMAX +*> \verbatim +*> AMAX is DOUBLE PRECISION +*> Absolute value of largest matrix entry. +*> \endverbatim +*> +*> \param[out] EQUED +*> \verbatim +*> EQUED is CHARACTER*1 +*> Specifies whether or not equilibration was done. +*> = 'N': No equilibration. +*> = 'Y': Equilibration was done, i.e., A has been replaced by +*> diag(S) * A * diag(S). +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> THRESH is a threshold value used to decide if scaling should be done +*> based on the ratio of the scaling factors. If SCOND < THRESH, +*> scaling is done. +*> +*> LARGE and SMALL are threshold values used to decide if scaling should +*> be done based on the absolute size of the largest matrix element. +*> If AMAX > LARGE or AMAX < SMALL, scaling is done. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER EQUED, UPLO + INTEGER N + DOUBLE PRECISION AMAX, SCOND +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), S( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, THRESH + PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, JC + DOUBLE PRECISION CJ, LARGE, SMALL +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + EQUED = 'N' + RETURN + END IF +* +* Initialize LARGE and SMALL. +* + SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + LARGE = ONE / SMALL +* + IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN +* +* No equilibration +* + EQUED = 'N' + ELSE +* +* Replace A by diag(S) * A * diag(S). +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Upper triangle of A is stored. +* + JC = 1 + DO 20 J = 1, N + CJ = S( J ) + DO 10 I = 1, J + AP( JC+I-1 ) = CJ*S( I )*AP( JC+I-1 ) + 10 CONTINUE + JC = JC + J + 20 CONTINUE + ELSE +* +* Lower triangle of A is stored. +* + JC = 1 + DO 40 J = 1, N + CJ = S( J ) + DO 30 I = J, N + AP( JC+I-J ) = CJ*S( I )*AP( JC+I-J ) + 30 CONTINUE + JC = JC + N - J + 1 + 40 CONTINUE + END IF + EQUED = 'Y' + END IF +* + RETURN +* +* End of DLAQSP +* + END diff --git a/math/lapack/src/main/fortran/dlaqsy.f b/math/lapack/src/main/fortran/dlaqsy.f new file mode 100644 index 0000000000..a3ed114678 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaqsy.f @@ -0,0 +1,216 @@ +*> \brief \b DLAQSY scales a symmetric/Hermitian matrix, using scaling factors computed by spoequ. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQSY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) +* +* .. Scalar Arguments .. +* CHARACTER EQUED, UPLO +* INTEGER LDA, N +* DOUBLE PRECISION AMAX, SCOND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), S( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQSY equilibrates a symmetric matrix A using the scaling factors +*> in the vector S. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n by n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n by n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if EQUED = 'Y', the equilibrated matrix: +*> diag(S) * A * diag(S). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(N,1). +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N) +*> The scale factors for A. +*> \endverbatim +*> +*> \param[in] SCOND +*> \verbatim +*> SCOND is DOUBLE PRECISION +*> Ratio of the smallest S(i) to the largest S(i). +*> \endverbatim +*> +*> \param[in] AMAX +*> \verbatim +*> AMAX is DOUBLE PRECISION +*> Absolute value of largest matrix entry. +*> \endverbatim +*> +*> \param[out] EQUED +*> \verbatim +*> EQUED is CHARACTER*1 +*> Specifies whether or not equilibration was done. +*> = 'N': No equilibration. +*> = 'Y': Equilibration was done, i.e., A has been replaced by +*> diag(S) * A * diag(S). +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> THRESH is a threshold value used to decide if scaling should be done +*> based on the ratio of the scaling factors. If SCOND < THRESH, +*> scaling is done. +*> +*> LARGE and SMALL are threshold values used to decide if scaling should +*> be done based on the absolute size of the largest matrix element. +*> If AMAX > LARGE or AMAX < SMALL, scaling is done. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYauxiliary +* +* ===================================================================== + SUBROUTINE DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER EQUED, UPLO + INTEGER LDA, N + DOUBLE PRECISION AMAX, SCOND +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), S( * ) +* .. +* +* ===================================================================== +* +* .. 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 .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + EQUED = 'N' + RETURN + END IF +* +* Initialize LARGE and SMALL. +* + SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + LARGE = ONE / SMALL +* + IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN +* +* No equilibration +* + EQUED = 'N' + ELSE +* +* Replace A by diag(S) * A * diag(S). +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Upper triangle of A is stored. +* + DO 20 J = 1, N + CJ = S( J ) + DO 10 I = 1, J + A( I, J ) = CJ*S( I )*A( I, J ) + 10 CONTINUE + 20 CONTINUE + ELSE +* +* Lower triangle of A is stored. +* + DO 40 J = 1, N + CJ = S( J ) + DO 30 I = J, N + A( I, J ) = CJ*S( I )*A( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + EQUED = 'Y' + END IF +* + RETURN +* +* End of DLAQSY +* + END diff --git a/math/lapack/src/main/fortran/dlaqtr.f b/math/lapack/src/main/fortran/dlaqtr.f new file mode 100644 index 0000000000..71c441fa3b --- /dev/null +++ b/math/lapack/src/main/fortran/dlaqtr.f @@ -0,0 +1,748 @@ +*> \brief \b DLAQTR solves a real quasi-triangular system of equations, or a complex quasi-triangular system of special form, in real arithmetic. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* LOGICAL LREAL, LTRAN +* INTEGER INFO, LDT, N +* DOUBLE PRECISION SCALE, W +* .. +* .. Array Arguments .. +* DOUBLE PRECISION B( * ), T( LDT, * ), WORK( * ), X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQTR solves the real quasi-triangular system +*> +*> op(T)*p = scale*c, if LREAL = .TRUE. +*> +*> or the complex quasi-triangular systems +*> +*> op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE. +*> +*> in real arithmetic, where T is upper quasi-triangular. +*> If LREAL = .FALSE., then the first diagonal block of T must be +*> 1 by 1, B is the specially structured matrix +*> +*> B = [ b(1) b(2) ... b(n) ] +*> [ w ] +*> [ w ] +*> [ . ] +*> [ w ] +*> +*> op(A) = A or A**T, A**T denotes the transpose of +*> matrix A. +*> +*> On input, X = [ c ]. On output, X = [ p ]. +*> [ d ] [ q ] +*> +*> This subroutine is designed for the condition number estimation +*> in routine DTRSNA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] LTRAN +*> \verbatim +*> LTRAN is LOGICAL +*> On entry, LTRAN specifies the option of conjugate transpose: +*> = .FALSE., op(T+i*B) = T+i*B, +*> = .TRUE., op(T+i*B) = (T+i*B)**T. +*> \endverbatim +*> +*> \param[in] LREAL +*> \verbatim +*> LREAL is LOGICAL +*> On entry, LREAL specifies the input matrix structure: +*> = .FALSE., the input is complex +*> = .TRUE., the input is real +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of T+i*B. N >= 0. +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> On entry, T contains a matrix in Schur canonical form. +*> If LREAL = .FALSE., then the first diagonal block of T mu +*> be 1 by 1. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the matrix T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (N) +*> On entry, B contains the elements to form the matrix +*> B as described above. +*> If LREAL = .TRUE., B is not referenced. +*> \endverbatim +*> +*> \param[in] W +*> \verbatim +*> W is DOUBLE PRECISION +*> On entry, W is the diagonal element of the matrix B. +*> If LREAL = .TRUE., W is not referenced. +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION +*> On exit, SCALE is the scale factor. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (2*N) +*> On entry, X contains the right hand side of the system. +*> On exit, X is overwritten by the solution. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> On exit, INFO is set to +*> 0: successful exit. +*> 1: the some diagonal 1 by 1 block has been perturbed by +*> a small number SMIN to keep nonsingularity. +*> 2: the some diagonal 2 by 2 block has been perturbed by +*> a small number in DLALN2 to keep nonsingularity. +*> NOTE: In the interests of speed, this routine does not +*> check the inputs for errors. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, + $ INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + LOGICAL LREAL, LTRAN + INTEGER INFO, LDT, N + DOUBLE PRECISION SCALE, W +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( * ), T( LDT, * ), WORK( * ), X( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN + INTEGER I, IERR, J, J1, J2, JNEXT, K, N1, N2 + DOUBLE PRECISION BIGNUM, EPS, REC, SCALOC, SI, SMIN, SMINW, + $ SMLNUM, SR, TJJ, TMP, XJ, XMAX, XNORM, Z +* .. +* .. Local Arrays .. + DOUBLE PRECISION D( 2, 2 ), V( 2, 2 ) +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DASUM, DDOT, DLAMCH, DLANGE + EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DLADIV, DLALN2, DSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Do not test the input parameters for errors +* + NOTRAN = .NOT.LTRAN + INFO = 0 +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Set constants to control overflow +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + BIGNUM = ONE / SMLNUM +* + XNORM = DLANGE( 'M', N, N, T, LDT, D ) + IF( .NOT.LREAL ) + $ XNORM = MAX( XNORM, ABS( W ), DLANGE( 'M', N, 1, B, N, D ) ) + SMIN = MAX( SMLNUM, EPS*XNORM ) +* +* Compute 1-norm of each column of strictly upper triangular +* part of T to control overflow in triangular solver. +* + WORK( 1 ) = ZERO + DO 10 J = 2, N + WORK( J ) = DASUM( J-1, T( 1, J ), 1 ) + 10 CONTINUE +* + IF( .NOT.LREAL ) THEN + DO 20 I = 2, N + WORK( I ) = WORK( I ) + ABS( B( I ) ) + 20 CONTINUE + END IF +* + N2 = 2*N + N1 = N + IF( .NOT.LREAL ) + $ N1 = N2 + K = IDAMAX( N1, X, 1 ) + XMAX = ABS( X( K ) ) + SCALE = ONE +* + IF( XMAX.GT.BIGNUM ) THEN + SCALE = BIGNUM / XMAX + CALL DSCAL( N1, SCALE, X, 1 ) + XMAX = BIGNUM + END IF +* + IF( LREAL ) THEN +* + IF( NOTRAN ) THEN +* +* Solve T*p = scale*c +* + JNEXT = N + DO 30 J = N, 1, -1 + IF( J.GT.JNEXT ) + $ GO TO 30 + J1 = J + J2 = J + JNEXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + J1 = J - 1 + JNEXT = J - 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* Meet 1 by 1 diagonal block +* +* Scale to avoid overflow when computing +* x(j) = b(j)/T(j,j) +* + XJ = ABS( X( J1 ) ) + TJJ = ABS( T( J1, J1 ) ) + TMP = T( J1, J1 ) + IF( TJJ.LT.SMIN ) THEN + TMP = SMIN + TJJ = SMIN + INFO = 1 + END IF +* + IF( XJ.EQ.ZERO ) + $ GO TO 30 +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.BIGNUM*TJJ ) THEN + REC = ONE / XJ + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + X( J1 ) = X( J1 ) / TMP + XJ = ABS( X( J1 ) ) +* +* Scale x if necessary to avoid overflow when adding a +* multiple of column j1 of T. +* + IF( XJ.GT.ONE ) THEN + REC = ONE / XJ + IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + END IF + END IF + IF( J1.GT.1 ) THEN + CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 ) + K = IDAMAX( J1-1, X, 1 ) + XMAX = ABS( X( K ) ) + END IF +* + ELSE +* +* Meet 2 by 2 diagonal block +* +* Call 2 by 2 linear system solve, to take +* care of possible overflow by scaling factor. +* + D( 1, 1 ) = X( J1 ) + D( 2, 1 ) = X( J2 ) + CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, T( J1, J1 ), + $ LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2, + $ SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 2 +* + IF( SCALOC.NE.ONE ) THEN + CALL DSCAL( N, SCALOC, X, 1 ) + SCALE = SCALE*SCALOC + END IF + X( J1 ) = V( 1, 1 ) + X( J2 ) = V( 2, 1 ) +* +* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2)) +* to avoid overflow in updating right-hand side. +* + XJ = MAX( ABS( V( 1, 1 ) ), ABS( V( 2, 1 ) ) ) + IF( XJ.GT.ONE ) THEN + REC = ONE / XJ + IF( MAX( WORK( J1 ), WORK( J2 ) ).GT. + $ ( BIGNUM-XMAX )*REC ) THEN + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + END IF + END IF +* +* Update right-hand side +* + IF( J1.GT.1 ) THEN + CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 ) + CALL DAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 ) + K = IDAMAX( J1-1, X, 1 ) + XMAX = ABS( X( K ) ) + END IF +* + END IF +* + 30 CONTINUE +* + ELSE +* +* Solve T**T*p = scale*c +* + JNEXT = 1 + DO 40 J = 1, N + IF( J.LT.JNEXT ) + $ GO TO 40 + J1 = J + J2 = J + JNEXT = J + 1 + IF( J.LT.N ) THEN + IF( T( J+1, J ).NE.ZERO ) THEN + J2 = J + 1 + JNEXT = J + 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1 by 1 diagonal block +* +* Scale if necessary to avoid overflow in forming the +* right-hand side element by inner product. +* + XJ = ABS( X( J1 ) ) + IF( XMAX.GT.ONE ) THEN + REC = ONE / XMAX + IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF +* + X( J1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, 1 ) +* + XJ = ABS( X( J1 ) ) + TJJ = ABS( T( J1, J1 ) ) + TMP = T( J1, J1 ) + IF( TJJ.LT.SMIN ) THEN + TMP = SMIN + TJJ = SMIN + INFO = 1 + END IF +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.BIGNUM*TJJ ) THEN + REC = ONE / XJ + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + X( J1 ) = X( J1 ) / TMP + XMAX = MAX( XMAX, ABS( X( J1 ) ) ) +* + ELSE +* +* 2 by 2 diagonal block +* +* Scale if necessary to avoid overflow in forming the +* right-hand side elements by inner product. +* + XJ = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ) ) + IF( XMAX.GT.ONE ) THEN + REC = ONE / XMAX + IF( MAX( WORK( J2 ), WORK( J1 ) ).GT.( BIGNUM-XJ )* + $ REC ) THEN + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF +* + D( 1, 1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, + $ 1 ) + D( 2, 1 ) = X( J2 ) - DDOT( J1-1, T( 1, J2 ), 1, X, + $ 1 ) +* + CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J1, J1 ), + $ LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2, + $ SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 2 +* + IF( SCALOC.NE.ONE ) THEN + CALL DSCAL( N, SCALOC, X, 1 ) + SCALE = SCALE*SCALOC + END IF + X( J1 ) = V( 1, 1 ) + X( J2 ) = V( 2, 1 ) + XMAX = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ), XMAX ) +* + END IF + 40 CONTINUE + END IF +* + ELSE +* + SMINW = MAX( EPS*ABS( W ), SMIN ) + IF( NOTRAN ) THEN +* +* Solve (T + iB)*(p+iq) = c+id +* + JNEXT = N + DO 70 J = N, 1, -1 + IF( J.GT.JNEXT ) + $ GO TO 70 + J1 = J + J2 = J + JNEXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + J1 = J - 1 + JNEXT = J - 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1 by 1 diagonal block +* +* Scale if necessary to avoid overflow in division +* + Z = W + IF( J1.EQ.1 ) + $ Z = B( 1 ) + XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) ) + TJJ = ABS( T( J1, J1 ) ) + ABS( Z ) + TMP = T( J1, J1 ) + IF( TJJ.LT.SMINW ) THEN + TMP = SMINW + TJJ = SMINW + INFO = 1 + END IF +* + IF( XJ.EQ.ZERO ) + $ GO TO 70 +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.BIGNUM*TJJ ) THEN + REC = ONE / XJ + CALL DSCAL( N2, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + CALL DLADIV( X( J1 ), X( N+J1 ), TMP, Z, SR, SI ) + X( J1 ) = SR + X( N+J1 ) = SI + XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) ) +* +* Scale x if necessary to avoid overflow when adding a +* multiple of column j1 of T. +* + IF( XJ.GT.ONE ) THEN + REC = ONE / XJ + IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN + CALL DSCAL( N2, REC, X, 1 ) + SCALE = SCALE*REC + END IF + END IF +* + IF( J1.GT.1 ) THEN + CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 ) + CALL DAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1, + $ X( N+1 ), 1 ) +* + X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 ) + X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 ) +* + XMAX = ZERO + DO 50 K = 1, J1 - 1 + XMAX = MAX( XMAX, ABS( X( K ) )+ + $ ABS( X( K+N ) ) ) + 50 CONTINUE + END IF +* + ELSE +* +* Meet 2 by 2 diagonal block +* + D( 1, 1 ) = X( J1 ) + D( 2, 1 ) = X( J2 ) + D( 1, 2 ) = X( N+J1 ) + D( 2, 2 ) = X( N+J2 ) + CALL DLALN2( .FALSE., 2, 2, SMINW, ONE, T( J1, J1 ), + $ LDT, ONE, ONE, D, 2, ZERO, -W, V, 2, + $ SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 2 +* + IF( SCALOC.NE.ONE ) THEN + CALL DSCAL( 2*N, SCALOC, X, 1 ) + SCALE = SCALOC*SCALE + END IF + X( J1 ) = V( 1, 1 ) + X( J2 ) = V( 2, 1 ) + X( N+J1 ) = V( 1, 2 ) + X( N+J2 ) = V( 2, 2 ) +* +* Scale X(J1), .... to avoid overflow in +* updating right hand side. +* + XJ = MAX( ABS( V( 1, 1 ) )+ABS( V( 1, 2 ) ), + $ ABS( V( 2, 1 ) )+ABS( V( 2, 2 ) ) ) + IF( XJ.GT.ONE ) THEN + REC = ONE / XJ + IF( MAX( WORK( J1 ), WORK( J2 ) ).GT. + $ ( BIGNUM-XMAX )*REC ) THEN + CALL DSCAL( N2, REC, X, 1 ) + SCALE = SCALE*REC + END IF + END IF +* +* Update the right-hand side. +* + IF( J1.GT.1 ) THEN + CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 ) + CALL DAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 ) +* + CALL DAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1, + $ X( N+1 ), 1 ) + CALL DAXPY( J1-1, -X( N+J2 ), T( 1, J2 ), 1, + $ X( N+1 ), 1 ) +* + X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 ) + + $ B( J2 )*X( N+J2 ) + X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 ) - + $ B( J2 )*X( J2 ) +* + XMAX = ZERO + DO 60 K = 1, J1 - 1 + XMAX = MAX( ABS( X( K ) )+ABS( X( K+N ) ), + $ XMAX ) + 60 CONTINUE + END IF +* + END IF + 70 CONTINUE +* + ELSE +* +* Solve (T + iB)**T*(p+iq) = c+id +* + JNEXT = 1 + DO 80 J = 1, N + IF( J.LT.JNEXT ) + $ GO TO 80 + J1 = J + J2 = J + JNEXT = J + 1 + IF( J.LT.N ) THEN + IF( T( J+1, J ).NE.ZERO ) THEN + J2 = J + 1 + JNEXT = J + 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1 by 1 diagonal block +* +* Scale if necessary to avoid overflow in forming the +* right-hand side element by inner product. +* + XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) ) + IF( XMAX.GT.ONE ) THEN + REC = ONE / XMAX + IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN + CALL DSCAL( N2, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF +* + X( J1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, 1 ) + X( N+J1 ) = X( N+J1 ) - DDOT( J1-1, T( 1, J1 ), 1, + $ X( N+1 ), 1 ) + IF( J1.GT.1 ) THEN + X( J1 ) = X( J1 ) - B( J1 )*X( N+1 ) + X( N+J1 ) = X( N+J1 ) + B( J1 )*X( 1 ) + END IF + XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) ) +* + Z = W + IF( J1.EQ.1 ) + $ Z = B( 1 ) +* +* Scale if necessary to avoid overflow in +* complex division +* + TJJ = ABS( T( J1, J1 ) ) + ABS( Z ) + TMP = T( J1, J1 ) + IF( TJJ.LT.SMINW ) THEN + TMP = SMINW + TJJ = SMINW + INFO = 1 + END IF +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.BIGNUM*TJJ ) THEN + REC = ONE / XJ + CALL DSCAL( N2, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + CALL DLADIV( X( J1 ), X( N+J1 ), TMP, -Z, SR, SI ) + X( J1 ) = SR + X( J1+N ) = SI + XMAX = MAX( ABS( X( J1 ) )+ABS( X( J1+N ) ), XMAX ) +* + ELSE +* +* 2 by 2 diagonal block +* +* Scale if necessary to avoid overflow in forming the +* right-hand side element by inner product. +* + XJ = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ), + $ ABS( X( J2 ) )+ABS( X( N+J2 ) ) ) + IF( XMAX.GT.ONE ) THEN + REC = ONE / XMAX + IF( MAX( WORK( J1 ), WORK( J2 ) ).GT. + $ ( BIGNUM-XJ ) / XMAX ) THEN + CALL DSCAL( N2, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF +* + D( 1, 1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, + $ 1 ) + D( 2, 1 ) = X( J2 ) - DDOT( J1-1, T( 1, J2 ), 1, X, + $ 1 ) + D( 1, 2 ) = X( N+J1 ) - DDOT( J1-1, T( 1, J1 ), 1, + $ X( N+1 ), 1 ) + D( 2, 2 ) = X( N+J2 ) - DDOT( J1-1, T( 1, J2 ), 1, + $ X( N+1 ), 1 ) + D( 1, 1 ) = D( 1, 1 ) - B( J1 )*X( N+1 ) + D( 2, 1 ) = D( 2, 1 ) - B( J2 )*X( N+1 ) + D( 1, 2 ) = D( 1, 2 ) + B( J1 )*X( 1 ) + D( 2, 2 ) = D( 2, 2 ) + B( J2 )*X( 1 ) +* + CALL DLALN2( .TRUE., 2, 2, SMINW, ONE, T( J1, J1 ), + $ LDT, ONE, ONE, D, 2, ZERO, W, V, 2, + $ SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 2 +* + IF( SCALOC.NE.ONE ) THEN + CALL DSCAL( N2, SCALOC, X, 1 ) + SCALE = SCALOC*SCALE + END IF + X( J1 ) = V( 1, 1 ) + X( J2 ) = V( 2, 1 ) + X( N+J1 ) = V( 1, 2 ) + X( N+J2 ) = V( 2, 2 ) + XMAX = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ), + $ ABS( X( J2 ) )+ABS( X( N+J2 ) ), XMAX ) +* + END IF +* + 80 CONTINUE +* + END IF +* + END IF +* + RETURN +* +* End of DLAQTR +* + END diff --git a/math/lapack/src/main/fortran/dlar1v.f b/math/lapack/src/main/fortran/dlar1v.f new file mode 100644 index 0000000000..3fa7178cf1 --- /dev/null +++ b/math/lapack/src/main/fortran/dlar1v.f @@ -0,0 +1,486 @@ +*> \brief \b DLAR1V computes the (scaled) r-th column of the inverse of the submatrix in rows b1 through bn of the tridiagonal matrix LDLT - λI. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAR1V + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, +* PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, +* R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) +* +* .. Scalar Arguments .. +* LOGICAL WANTNC +* INTEGER B1, BN, N, NEGCNT, R +* DOUBLE PRECISION GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID, +* $ RQCORR, ZTZ +* .. +* .. Array Arguments .. +* INTEGER ISUPPZ( * ) +* DOUBLE PRECISION D( * ), L( * ), LD( * ), LLD( * ), +* $ WORK( * ) +* DOUBLE PRECISION Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAR1V computes the (scaled) r-th column of the inverse of +*> the sumbmatrix in rows B1 through BN of the tridiagonal matrix +*> L D L**T - sigma I. When sigma is close to an eigenvalue, the +*> computed vector is an accurate eigenvector. Usually, r corresponds +*> to the index where the eigenvector is largest in magnitude. +*> The following steps accomplish this computation : +*> (a) Stationary qd transform, L D L**T - sigma I = L(+) D(+) L(+)**T, +*> (b) Progressive qd transform, L D L**T - sigma I = U(-) D(-) U(-)**T, +*> (c) Computation of the diagonal elements of the inverse of +*> L D L**T - sigma I by combining the above transforms, and choosing +*> r as the index where the diagonal of the inverse is (one of the) +*> largest in magnitude. +*> (d) Computation of the (scaled) r-th column of the inverse using the +*> twisted factorization obtained by combining the top part of the +*> the stationary and the bottom part of the progressive transform. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix L D L**T. +*> \endverbatim +*> +*> \param[in] B1 +*> \verbatim +*> B1 is INTEGER +*> First index of the submatrix of L D L**T. +*> \endverbatim +*> +*> \param[in] BN +*> \verbatim +*> BN is INTEGER +*> Last index of the submatrix of L D L**T. +*> \endverbatim +*> +*> \param[in] LAMBDA +*> \verbatim +*> LAMBDA is DOUBLE PRECISION +*> The shift. In order to compute an accurate eigenvector, +*> LAMBDA should be a good approximation to an eigenvalue +*> of L D L**T. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) subdiagonal elements of the unit bidiagonal matrix +*> L, in elements 1 to N-1. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of the diagonal matrix D. +*> \endverbatim +*> +*> \param[in] LD +*> \verbatim +*> LD is DOUBLE PRECISION array, dimension (N-1) +*> The n-1 elements L(i)*D(i). +*> \endverbatim +*> +*> \param[in] LLD +*> \verbatim +*> LLD is DOUBLE PRECISION array, dimension (N-1) +*> The n-1 elements L(i)*L(i)*D(i). +*> \endverbatim +*> +*> \param[in] PIVMIN +*> \verbatim +*> PIVMIN is DOUBLE PRECISION +*> The minimum pivot in the Sturm sequence. +*> \endverbatim +*> +*> \param[in] GAPTOL +*> \verbatim +*> GAPTOL is DOUBLE PRECISION +*> Tolerance that indicates when eigenvector entries are negligible +*> w.r.t. their contribution to the residual. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (N) +*> On input, all entries of Z must be set to 0. +*> On output, Z contains the (scaled) r-th column of the +*> inverse. The scaling is such that Z(R) equals 1. +*> \endverbatim +*> +*> \param[in] WANTNC +*> \verbatim +*> WANTNC is LOGICAL +*> Specifies whether NEGCNT has to be computed. +*> \endverbatim +*> +*> \param[out] NEGCNT +*> \verbatim +*> NEGCNT is INTEGER +*> If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin +*> in the matrix factorization L D L**T, and NEGCNT = -1 otherwise. +*> \endverbatim +*> +*> \param[out] ZTZ +*> \verbatim +*> ZTZ is DOUBLE PRECISION +*> The square of the 2-norm of Z. +*> \endverbatim +*> +*> \param[out] MINGMA +*> \verbatim +*> MINGMA is DOUBLE PRECISION +*> The reciprocal of the largest (in magnitude) diagonal +*> element of the inverse of L D L**T - sigma I. +*> \endverbatim +*> +*> \param[in,out] R +*> \verbatim +*> R is INTEGER +*> The twist index for the twisted factorization used to +*> compute Z. +*> On input, 0 <= R <= N. If R is input as 0, R is set to +*> the index where (L D L**T - sigma I)^{-1} is largest +*> in magnitude. If 1 <= R <= N, R is unchanged. +*> On output, R contains the twist index used to compute Z. +*> Ideally, R designates the position of the maximum entry in the +*> eigenvector. +*> \endverbatim +*> +*> \param[out] ISUPPZ +*> \verbatim +*> ISUPPZ is INTEGER array, dimension (2) +*> The support of the vector in Z, i.e., the vector Z is +*> nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ). +*> \endverbatim +*> +*> \param[out] NRMINV +*> \verbatim +*> NRMINV is DOUBLE PRECISION +*> NRMINV = 1/SQRT( ZTZ ) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is DOUBLE PRECISION +*> The residual of the FP vector. +*> RESID = ABS( MINGMA )/SQRT( ZTZ ) +*> \endverbatim +*> +*> \param[out] RQCORR +*> \verbatim +*> RQCORR is DOUBLE PRECISION +*> The Rayleigh Quotient correction to LAMBDA. +*> RQCORR = MINGMA*TMP +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Beresford Parlett, University of California, Berkeley, USA \n +*> Jim Demmel, University of California, Berkeley, USA \n +*> Inderjit Dhillon, University of Texas, Austin, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Christof Voemel, University of California, Berkeley, USA +* +* ===================================================================== + SUBROUTINE DLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, + $ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, + $ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + LOGICAL WANTNC + INTEGER B1, BN, N, NEGCNT, R + DOUBLE PRECISION GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID, + $ RQCORR, ZTZ +* .. +* .. Array Arguments .. + INTEGER ISUPPZ( * ) + DOUBLE PRECISION D( * ), L( * ), LD( * ), LLD( * ), + $ WORK( * ) + DOUBLE PRECISION Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + +* .. +* .. Local Scalars .. + LOGICAL SAWNAN1, SAWNAN2 + INTEGER I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1, + $ R2 + DOUBLE PRECISION DMINUS, DPLUS, EPS, S, TMP +* .. +* .. External Functions .. + LOGICAL DISNAN + DOUBLE PRECISION DLAMCH + EXTERNAL DISNAN, DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + EPS = DLAMCH( 'Precision' ) + + + IF( R.EQ.0 ) THEN + R1 = B1 + R2 = BN + ELSE + R1 = R + R2 = R + END IF + +* Storage for LPLUS + INDLPL = 0 +* Storage for UMINUS + INDUMN = N + INDS = 2*N + 1 + INDP = 3*N + 1 + + IF( B1.EQ.1 ) THEN + WORK( INDS ) = ZERO + ELSE + WORK( INDS+B1-1 ) = LLD( B1-1 ) + END IF + +* +* Compute the stationary transform (using the differential form) +* until the index R2. +* + SAWNAN1 = .FALSE. + NEG1 = 0 + S = WORK( INDS+B1-1 ) - LAMBDA + DO 50 I = B1, R1 - 1 + DPLUS = D( I ) + S + WORK( INDLPL+I ) = LD( I ) / DPLUS + IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1 + WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I ) + S = WORK( INDS+I ) - LAMBDA + 50 CONTINUE + SAWNAN1 = DISNAN( S ) + IF( SAWNAN1 ) GOTO 60 + DO 51 I = R1, R2 - 1 + DPLUS = D( I ) + S + WORK( INDLPL+I ) = LD( I ) / DPLUS + WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I ) + S = WORK( INDS+I ) - LAMBDA + 51 CONTINUE + SAWNAN1 = DISNAN( S ) +* + 60 CONTINUE + IF( SAWNAN1 ) THEN +* Runs a slower version of the above loop if a NaN is detected + NEG1 = 0 + S = WORK( INDS+B1-1 ) - LAMBDA + DO 70 I = B1, R1 - 1 + DPLUS = D( I ) + S + IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN + WORK( INDLPL+I ) = LD( I ) / DPLUS + IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1 + WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I ) + IF( WORK( INDLPL+I ).EQ.ZERO ) + $ WORK( INDS+I ) = LLD( I ) + S = WORK( INDS+I ) - LAMBDA + 70 CONTINUE + DO 71 I = R1, R2 - 1 + DPLUS = D( I ) + S + IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN + WORK( INDLPL+I ) = LD( I ) / DPLUS + WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I ) + IF( WORK( INDLPL+I ).EQ.ZERO ) + $ WORK( INDS+I ) = LLD( I ) + S = WORK( INDS+I ) - LAMBDA + 71 CONTINUE + END IF +* +* Compute the progressive transform (using the differential form) +* until the index R1 +* + SAWNAN2 = .FALSE. + NEG2 = 0 + WORK( INDP+BN-1 ) = D( BN ) - LAMBDA + DO 80 I = BN - 1, R1, -1 + DMINUS = LLD( I ) + WORK( INDP+I ) + TMP = D( I ) / DMINUS + IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1 + WORK( INDUMN+I ) = L( I )*TMP + WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA + 80 CONTINUE + TMP = WORK( INDP+R1-1 ) + SAWNAN2 = DISNAN( TMP ) + + IF( SAWNAN2 ) THEN +* Runs a slower version of the above loop if a NaN is detected + NEG2 = 0 + DO 100 I = BN-1, R1, -1 + DMINUS = LLD( I ) + WORK( INDP+I ) + IF(ABS(DMINUS).LT.PIVMIN) DMINUS = -PIVMIN + TMP = D( I ) / DMINUS + IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1 + WORK( INDUMN+I ) = L( I )*TMP + WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA + IF( TMP.EQ.ZERO ) + $ WORK( INDP+I-1 ) = D( I ) - LAMBDA + 100 CONTINUE + END IF +* +* Find the index (from R1 to R2) of the largest (in magnitude) +* diagonal element of the inverse +* + MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 ) + IF( MINGMA.LT.ZERO ) NEG1 = NEG1 + 1 + IF( WANTNC ) THEN + NEGCNT = NEG1 + NEG2 + ELSE + NEGCNT = -1 + ENDIF + IF( ABS(MINGMA).EQ.ZERO ) + $ MINGMA = EPS*WORK( INDS+R1-1 ) + R = R1 + DO 110 I = R1, R2 - 1 + TMP = WORK( INDS+I ) + WORK( INDP+I ) + IF( TMP.EQ.ZERO ) + $ TMP = EPS*WORK( INDS+I ) + IF( ABS( TMP ).LE.ABS( MINGMA ) ) THEN + MINGMA = TMP + R = I + 1 + END IF + 110 CONTINUE +* +* Compute the FP vector: solve N^T v = e_r +* + ISUPPZ( 1 ) = B1 + ISUPPZ( 2 ) = BN + Z( R ) = ONE + ZTZ = ONE +* +* Compute the FP vector upwards from R +* + IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN + DO 210 I = R-1, B1, -1 + Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) ) + IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL ) + $ THEN + Z( I ) = ZERO + ISUPPZ( 1 ) = I + 1 + GOTO 220 + ENDIF + ZTZ = ZTZ + Z( I )*Z( I ) + 210 CONTINUE + 220 CONTINUE + ELSE +* Run slower loop if NaN occurred. + DO 230 I = R - 1, B1, -1 + IF( Z( I+1 ).EQ.ZERO ) THEN + Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 ) + ELSE + Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) ) + END IF + IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL ) + $ THEN + Z( I ) = ZERO + ISUPPZ( 1 ) = I + 1 + GO TO 240 + END IF + ZTZ = ZTZ + Z( I )*Z( I ) + 230 CONTINUE + 240 CONTINUE + ENDIF + +* Compute the FP vector downwards from R in blocks of size BLKSIZ + IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN + DO 250 I = R, BN-1 + Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) ) + IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL ) + $ THEN + Z( I+1 ) = ZERO + ISUPPZ( 2 ) = I + GO TO 260 + END IF + ZTZ = ZTZ + Z( I+1 )*Z( I+1 ) + 250 CONTINUE + 260 CONTINUE + ELSE +* Run slower loop if NaN occurred. + DO 270 I = R, BN - 1 + IF( Z( I ).EQ.ZERO ) THEN + Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 ) + ELSE + Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) ) + END IF + IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL ) + $ THEN + Z( I+1 ) = ZERO + ISUPPZ( 2 ) = I + GO TO 280 + END IF + ZTZ = ZTZ + Z( I+1 )*Z( I+1 ) + 270 CONTINUE + 280 CONTINUE + END IF +* +* Compute quantities for convergence test +* + TMP = ONE / ZTZ + NRMINV = SQRT( TMP ) + RESID = ABS( MINGMA )*NRMINV + RQCORR = MINGMA*TMP +* +* + RETURN +* +* End of DLAR1V +* + END diff --git a/math/lapack/src/main/fortran/dlar2v.f b/math/lapack/src/main/fortran/dlar2v.f new file mode 100644 index 0000000000..32c77bf70e --- /dev/null +++ b/math/lapack/src/main/fortran/dlar2v.f @@ -0,0 +1,157 @@ +*> \brief \b DLAR2V applies a vector of plane rotations with real cosines and real sines from both sides to a sequence of 2-by-2 symmetric/Hermitian matrices. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAR2V + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC ) +* +* .. Scalar Arguments .. +* INTEGER INCC, INCX, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( * ), S( * ), X( * ), Y( * ), Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAR2V applies a vector of real plane rotations from both sides to +*> a sequence of 2-by-2 real symmetric matrices, defined by the elements +*> of the vectors x, y and z. For i = 1,2,...,n +*> +*> ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) ) +*> ( z(i) y(i) ) ( -s(i) c(i) ) ( z(i) y(i) ) ( s(i) c(i) ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of plane rotations to be applied. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, +*> dimension (1+(N-1)*INCX) +*> The vector x. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, +*> dimension (1+(N-1)*INCX) +*> The vector y. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, +*> dimension (1+(N-1)*INCX) +*> The vector z. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The increment between elements of X, Y and Z. INCX > 0. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC) +*> The cosines of the plane rotations. +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (1+(N-1)*INCC) +*> The sines of the plane rotations. +*> \endverbatim +*> +*> \param[in] INCC +*> \verbatim +*> INCC is INTEGER +*> The increment between elements of C and S. INCC > 0. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCC, INCX, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( * ), S( * ), X( * ), Y( * ), Z( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IC, IX + DOUBLE PRECISION CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI +* .. +* .. Executable Statements .. +* + IX = 1 + IC = 1 + DO 10 I = 1, N + XI = X( IX ) + YI = Y( IX ) + ZI = Z( IX ) + CI = C( IC ) + SI = S( IC ) + T1 = SI*ZI + T2 = CI*ZI + T3 = T2 - SI*XI + T4 = T2 + SI*YI + T5 = CI*XI + T1 + T6 = CI*YI - T1 + X( IX ) = CI*T5 + SI*T4 + Y( IX ) = CI*T6 - SI*T3 + Z( IX ) = CI*T4 - SI*T5 + IX = IX + INCX + IC = IC + INCC + 10 CONTINUE +* +* End of DLAR2V +* + RETURN + END diff --git a/math/lapack/src/main/fortran/dlarf.f b/math/lapack/src/main/fortran/dlarf.f new file mode 100644 index 0000000000..e99d0bb2a9 --- /dev/null +++ b/math/lapack/src/main/fortran/dlarf.f @@ -0,0 +1,227 @@ +*> \brief \b DLARF applies an elementary reflector to a general rectangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER INCV, LDC, M, N +* DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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**T +*> +*> where tau is a real scalar and v is a real vector. +*> +*> If tau = 0, then H is taken to be the unit matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension +*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' +*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +*> The vector v in the representation of H. V is not used if +*> TAU = 0. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between elements of v. INCV <> 0. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILADLR, ILADLC + EXTERNAL LSAME, ILADLR, ILADLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 0 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V. + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILADLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILADLR(M, LASTV, C, LDC) + END IF + END IF +! Note that lastc.eq.0 renders the BLAS operations null; no special +! case is needed at this level. + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) +* + CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, + $ ZERO, WORK, 1 ) +* +* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T +* + CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) +* + CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, + $ V, INCV, ZERO, WORK, 1 ) +* +* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T +* + CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) + END IF + END IF + RETURN +* +* End of DLARF +* + END diff --git a/math/lapack/src/main/fortran/dlarfb.f b/math/lapack/src/main/fortran/dlarfb.f new file mode 100644 index 0000000000..5b2cc2ba80 --- /dev/null +++ b/math/lapack/src/main/fortran/dlarfb.f @@ -0,0 +1,710 @@ +*> \brief \b DLARFB applies a block reflector or its transpose to a general rectangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARFB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, +* T, LDT, C, LDC, WORK, LDWORK ) +* +* .. 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARFB applies a real block reflector H or its transpose H**T to a +*> real m by n matrix C, from either the left or the right. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply H or H**T from the Left +*> = 'R': apply H or H**T from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply H (No transpose) +*> = 'T': apply H**T (Transpose) +*> \endverbatim +*> +*> \param[in] DIRECT +*> \verbatim +*> DIRECT is 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) +*> \endverbatim +*> +*> \param[in] STOREV +*> \verbatim +*> STOREV is CHARACTER*1 +*> Indicates how the vectors which define the elementary +*> reflectors are stored: +*> = 'C': Columnwise +*> = 'R': Rowwise +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The order of the matrix T (= the number of elementary +*> reflectors whose product defines the block reflector). +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is 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. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is 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. +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,K) +*> The triangular k by k matrix T in the representation of the +*> block reflector. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= K. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LDWORK,K) +*> \endverbatim +*> +*> \param[in] LDWORK +*> \verbatim +*> LDWORK is INTEGER +*> The leading dimension of the array WORK. +*> If SIDE = 'L', LDWORK >= max(1,N); +*> if SIDE = 'R', LDWORK >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2013 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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 ) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, + $ T, LDT, C, LDC, WORK, LDWORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2013 +* +* .. 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, * ) +* .. +* +* ===================================================================== +* +* .. 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**T * C where C = ( C1 ) +* ( C2 ) +* +* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) +* +* W := C1**T +* + 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**T * 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**T or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**T +* + IF( M.GT.K ) THEN +* +* C2 := C2 - V2 * W**T +* + 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**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**T +* + 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**T 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**T +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**T +* + IF( N.GT.K ) THEN +* +* C2 := C2 - W * V2**T +* + 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**T +* + 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**T * C where C = ( C1 ) +* ( C2 ) +* +* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) +* +* W := C2**T +* + 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**T * V1 +* + CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**T +* + IF( M.GT.K ) THEN +* +* C1 := C1 - V1 * W**T +* + CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) + END IF +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W**T +* + 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**T 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**T +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**T +* + IF( N.GT.K ) THEN +* +* C1 := C1 - W * V1**T +* + CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) + END IF +* +* W := W * V2**T +* + 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**T * C where C = ( C1 ) +* ( C2 ) +* +* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) +* +* W := C1**T +* + DO 130 J = 1, K + CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 130 CONTINUE +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C2**T * V2**T +* + 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**T or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**T * W**T +* + IF( M.GT.K ) THEN +* +* C2 := C2 - V2**T * W**T +* + 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**T +* + 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**T where C = ( C1 C2 ) +* +* W := C * V**T = (C1*V1**T + C2*V2**T) (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**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C2 * V2**T +* + 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**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**T * C where C = ( C1 ) +* ( C2 ) +* +* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) +* +* W := C2**T +* + DO 190 J = 1, K + CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + 190 CONTINUE +* +* W := W * V2**T +* + 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**T * V1**T +* + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**T * W**T +* + IF( M.GT.K ) THEN +* +* C1 := C1 - V1**T * W**T +* + 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**T +* + 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**T = (C1*V1**T + C2*V2**T) (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**T +* + 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**T +* + 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**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/math/lapack/src/main/fortran/dlarfg.f b/math/lapack/src/main/fortran/dlarfg.f new file mode 100644 index 0000000000..cb177a5703 --- /dev/null +++ b/math/lapack/src/main/fortran/dlarfg.f @@ -0,0 +1,196 @@ +*> \brief \b DLARFG generates an elementary reflector (Householder matrix). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARFG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) +* +* .. Scalar Arguments .. +* INTEGER INCX, N +* DOUBLE PRECISION ALPHA, TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARFG generates a real elementary reflector H of order n, such +*> that +*> +*> H * ( alpha ) = ( beta ), H**T * 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**T ) , +*> ( 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the elementary reflector. +*> \endverbatim +*> +*> \param[in,out] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> On entry, the value alpha. +*> On exit, it is overwritten with the value beta. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension +*> (1+(N-2)*abs(INCX)) +*> On entry, the vector x. +*> On exit, it is overwritten with the vector v. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The increment between elements of X. INCX > 0. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> The value tau. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION ALPHA, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* ===================================================================== +* +* .. 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' ) + KNT = 0 + IF( ABS( BETA ).LT.SAFMIN ) THEN +* +* XNORM, BETA may be inaccurate; scale X and recompute them +* + RSAFMN = ONE / SAFMIN + 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 ) + END IF + TAU = ( BETA-ALPHA ) / BETA + CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) +* +* If ALPHA is subnormal, it may lose relative accuracy +* + DO 20 J = 1, KNT + BETA = BETA*SAFMIN + 20 CONTINUE + ALPHA = BETA + END IF +* + RETURN +* +* End of DLARFG +* + END diff --git a/math/lapack/src/main/fortran/dlarfgp.f b/math/lapack/src/main/fortran/dlarfgp.f new file mode 100644 index 0000000000..c05f837ea2 --- /dev/null +++ b/math/lapack/src/main/fortran/dlarfgp.f @@ -0,0 +1,242 @@ +*> \brief \b DLARFGP generates an elementary reflector (Householder matrix) with non-negative beta. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARFGP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARFGP( N, ALPHA, X, INCX, TAU ) +* +* .. Scalar Arguments .. +* INTEGER INCX, N +* DOUBLE PRECISION ALPHA, TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARFGP generates a real elementary reflector H of order n, such +*> that +*> +*> H * ( alpha ) = ( beta ), H**T * H = I. +*> ( x ) ( 0 ) +*> +*> where alpha and beta are scalars, beta is non-negative, and x is +*> an (n-1)-element real vector. H is represented in the form +*> +*> H = I - tau * ( 1 ) * ( 1 v**T ) , +*> ( 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the elementary reflector. +*> \endverbatim +*> +*> \param[in,out] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> On entry, the value alpha. +*> On exit, it is overwritten with the value beta. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension +*> (1+(N-2)*abs(INCX)) +*> On entry, the vector x. +*> On exit, it is overwritten with the vector v. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The increment between elements of X. INCX > 0. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> The value tau. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLARFGP( N, ALPHA, X, INCX, TAU ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION ALPHA, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION TWO, ONE, ZERO + PARAMETER ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER J, KNT + DOUBLE PRECISION BETA, BIGNUM, SAVEALPHA, SMLNUM, 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.0 ) THEN + TAU = ZERO + RETURN + END IF +* + XNORM = DNRM2( N-1, X, INCX ) +* + IF( XNORM.EQ.ZERO ) THEN +* +* H = [+/-1, 0; I], sign chosen so ALPHA >= 0 +* + IF( ALPHA.GE.ZERO ) THEN +* When TAU.eq.ZERO, the vector is special-cased to be +* all zeros in the application routines. We do not need +* to clear it. + TAU = ZERO + ELSE +* However, the application routines rely on explicit +* zero checks when TAU.ne.ZERO, and we must clear X. + TAU = TWO + DO J = 1, N-1 + X( 1 + (J-1)*INCX ) = 0 + END DO + ALPHA = -ALPHA + END IF + ELSE +* +* general case +* + BETA = SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'E' ) + KNT = 0 + IF( ABS( BETA ).LT.SMLNUM ) THEN +* +* XNORM, BETA may be inaccurate; scale X and recompute them +* + BIGNUM = ONE / SMLNUM + 10 CONTINUE + KNT = KNT + 1 + CALL DSCAL( N-1, BIGNUM, X, INCX ) + BETA = BETA*BIGNUM + ALPHA = ALPHA*BIGNUM + IF( ABS( BETA ).LT.SMLNUM ) + $ GO TO 10 +* +* New BETA is at most 1, at least SMLNUM +* + XNORM = DNRM2( N-1, X, INCX ) + BETA = SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + END IF + SAVEALPHA = ALPHA + ALPHA = ALPHA + BETA + IF( BETA.LT.ZERO ) THEN + BETA = -BETA + TAU = -ALPHA / BETA + ELSE + ALPHA = XNORM * (XNORM/ALPHA) + TAU = ALPHA / BETA + ALPHA = -ALPHA + END IF +* + IF ( ABS(TAU).LE.SMLNUM ) THEN +* +* In the case where the computed TAU ends up being a denormalized number, +* it loses relative accuracy. This is a BIG problem. Solution: flush TAU +* to ZERO. This explains the next IF statement. +* +* (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.) +* (Thanks Pat. Thanks MathWorks.) +* + IF( SAVEALPHA.GE.ZERO ) THEN + TAU = ZERO + ELSE + TAU = TWO + DO J = 1, N-1 + X( 1 + (J-1)*INCX ) = 0 + END DO + BETA = -SAVEALPHA + END IF +* + ELSE +* +* This is the general case. +* + CALL DSCAL( N-1, ONE / ALPHA, X, INCX ) +* + END IF +* +* If BETA is subnormal, it may lose relative accuracy +* + DO 20 J = 1, KNT + BETA = BETA*SMLNUM + 20 CONTINUE + ALPHA = BETA + END IF +* + RETURN +* +* End of DLARFGP +* + END diff --git a/math/lapack/src/main/fortran/dlarft.f b/math/lapack/src/main/fortran/dlarft.f new file mode 100644 index 0000000000..e69a6b792e --- /dev/null +++ b/math/lapack/src/main/fortran/dlarft.f @@ -0,0 +1,326 @@ +*> \brief \b DLARFT forms the triangular factor T of a block reflector H = I - vtvH +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARFT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* .. Scalar Arguments .. +* CHARACTER DIRECT, STOREV +* INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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**T +*> +*> 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 * T * V +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DIRECT +*> \verbatim +*> DIRECT is 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) +*> \endverbatim +*> +*> \param[in] STOREV +*> \verbatim +*> STOREV is CHARACTER*1 +*> Specifies how the vectors which define the elementary +*> reflectors are stored (see also Further Details): +*> = 'C': columnwise +*> = 'R': rowwise +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the block reflector H. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The order of the triangular factor T (= the number of +*> elementary reflectors). K >= 1. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension +*> (LDV,K) if STOREV = 'C' +*> (LDV,N) if STOREV = 'R' +*> The matrix V. See further details. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is 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. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= K. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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. +*> +*> 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 ) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, PREVLASTV, LASTV +* .. +* .. 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 + PREVLASTV = N + DO I = 1, K + PREVLASTV = MAX( I, PREVLASTV ) + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO J = 1, I + T( J, I ) = ZERO + END DO + ELSE +* +* general case +* + IF( LSAME( STOREV, 'C' ) ) THEN +* Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + DO J = 1, I-1 + T( J, I ) = -TAU( I ) * V( I , J ) + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) +* + CALL DGEMV( 'Transpose', J-I, I-1, -TAU( I ), + $ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE, + $ T( 1, I ), 1 ) + ELSE +* Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + DO J = 1, I-1 + T( J, I ) = -TAU( I ) * V( J , I ) + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T +* + CALL DGEMV( 'No transpose', I-1, J-I, -TAU( I ), + $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, ONE, + $ T( 1, I ), 1 ) + END IF +* +* 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 ) + IF( I.GT.1 ) THEN + PREVLASTV = MAX( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + END DO + ELSE + PREVLASTV = 1 + DO I = K, 1, -1 + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO J = I, K + T( J, I ) = ZERO + END DO + ELSE +* +* general case +* + IF( I.LT.K ) THEN + IF( LSAME( STOREV, 'C' ) ) THEN +* Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + DO J = I+1, K + T( J, I ) = -TAU( I ) * V( N-K+I , J ) + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) +* + CALL DGEMV( 'Transpose', N-K+I-J, K-I, -TAU( I ), + $ V( J, I+1 ), LDV, V( J, I ), 1, ONE, + $ T( I+1, I ), 1 ) + ELSE +* Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + DO J = I+1, K + T( J, I ) = -TAU( I ) * V( J, N-K+I ) + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T +* + CALL DGEMV( 'No transpose', K-I, N-K+I-J, + $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, + $ ONE, T( I+1, I ), 1 ) + 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 ) + IF( I.GT.1 ) THEN + PREVLASTV = MIN( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + T( I, I ) = TAU( I ) + END IF + END DO + END IF + RETURN +* +* End of DLARFT +* + END diff --git a/math/lapack/src/main/fortran/dlarfx.f b/math/lapack/src/main/fortran/dlarfx.f new file mode 100644 index 0000000000..260d367d48 --- /dev/null +++ b/math/lapack/src/main/fortran/dlarfx.f @@ -0,0 +1,697 @@ +*> \brief \b DLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the reflector has order ≤ 10. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARFX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER LDC, M, N +* DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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**T +*> +*> where tau is a real scalar and v is a real vector. +*> +*> If tau = 0, then H is taken to be the unit matrix +*> +*> This version uses inline code if H has order < 11. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (M) if SIDE = 'L' +*> or (N) if SIDE = 'R' +*> The vector v in the representation of H. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDA >= (1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> WORK is not referenced if H has order < 11. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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 DLARF +* .. +* .. 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 +* + CALL DLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) + 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 +* + CALL DLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) + 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/math/lapack/src/main/fortran/dlarfy.f b/math/lapack/src/main/fortran/dlarfy.f new file mode 100644 index 0000000000..a0b0ebb31b --- /dev/null +++ b/math/lapack/src/main/fortran/dlarfy.f @@ -0,0 +1,161 @@ +*> \brief \b DLARFY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INCV, LDC, N +* DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARFY applies an elementary reflector, or Householder matrix, H, +*> to an n x n symmetric matrix C, from both the left and the right. +*> +*> H is represented in the form +*> +*> H = I - tau * v * v' +*> +*> where tau is a scalar and v is a vector. +*> +*> If tau is zero, then H is taken to be the unit matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix C is stored. +*> = 'U': Upper triangle +*> = 'L': Lower triangle +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension +*> (1 + (N-1)*abs(INCV)) +*> The vector v as described above. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between successive elements of v. INCV must +*> not be zero. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> The value tau as described above. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC, N) +*> On entry, the matrix C. +*> On exit, C is overwritten by H * C * H'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max( 1, N ). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup double_eig +* +* ===================================================================== + SUBROUTINE DLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INCV, LDC, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO, HALF + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, HALF = 0.5D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION ALPHA +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DSYMV, DSYR2 +* .. +* .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +* .. +* .. Executable Statements .. +* + IF( TAU.EQ.ZERO ) + $ RETURN +* +* Form w:= C * v +* + CALL DSYMV( UPLO, N, ONE, C, LDC, V, INCV, ZERO, WORK, 1 ) +* + ALPHA = -HALF*TAU*DDOT( N, WORK, 1, V, INCV ) + CALL DAXPY( N, ALPHA, V, INCV, WORK, 1 ) +* +* C := C - v * w' - w * v' +* + CALL DSYR2( UPLO, N, -TAU, V, INCV, WORK, 1, C, LDC ) +* + RETURN +* +* End of DLARFY +* + END diff --git a/math/lapack/src/main/fortran/dlargv.f b/math/lapack/src/main/fortran/dlargv.f new file mode 100644 index 0000000000..f28bcecd3f --- /dev/null +++ b/math/lapack/src/main/fortran/dlargv.f @@ -0,0 +1,167 @@ +*> \brief \b DLARGV generates a vector of plane rotations with real cosines and real sines. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC ) +* +* .. Scalar Arguments .. +* INTEGER INCC, INCX, INCY, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( * ), X( * ), Y( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARGV generates a vector of real plane rotations, determined by +*> elements of the real vectors x and y. For i = 1,2,...,n +*> +*> ( c(i) s(i) ) ( x(i) ) = ( a(i) ) +*> ( -s(i) c(i) ) ( y(i) ) = ( 0 ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of plane rotations to be generated. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, +*> dimension (1+(N-1)*INCX) +*> On entry, the vector x. +*> On exit, x(i) is overwritten by a(i), for i = 1,...,n. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The increment between elements of X. INCX > 0. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, +*> dimension (1+(N-1)*INCY) +*> On entry, the vector y. +*> On exit, the sines of the plane rotations. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> The increment between elements of Y. INCY > 0. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC) +*> The cosines of the plane rotations. +*> \endverbatim +*> +*> \param[in] INCC +*> \verbatim +*> INCC is INTEGER +*> The increment between elements of C. INCC > 0. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCC, INCX, INCY, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( * ), X( * ), Y( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IC, IX, IY + DOUBLE PRECISION F, G, T, TT +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* + IX = 1 + IY = 1 + IC = 1 + DO 10 I = 1, N + F = X( IX ) + G = Y( IY ) + IF( G.EQ.ZERO ) THEN + C( IC ) = ONE + ELSE IF( F.EQ.ZERO ) THEN + C( IC ) = ZERO + Y( IY ) = ONE + X( IX ) = G + ELSE IF( ABS( F ).GT.ABS( G ) ) THEN + T = G / F + TT = SQRT( ONE+T*T ) + C( IC ) = ONE / TT + Y( IY ) = T*C( IC ) + X( IX ) = F*TT + ELSE + T = F / G + TT = SQRT( ONE+T*T ) + Y( IY ) = ONE / TT + C( IC ) = T*Y( IY ) + X( IX ) = G*TT + END IF + IC = IC + INCC + IY = IY + INCY + IX = IX + INCX + 10 CONTINUE + RETURN +* +* End of DLARGV +* + END diff --git a/math/lapack/src/main/fortran/dlarnv.f b/math/lapack/src/main/fortran/dlarnv.f new file mode 100644 index 0000000000..02e62bc6ff --- /dev/null +++ b/math/lapack/src/main/fortran/dlarnv.f @@ -0,0 +1,178 @@ +*> \brief \b DLARNV returns a vector of random numbers from a uniform or normal distribution. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARNV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARNV( IDIST, ISEED, N, X ) +* +* .. Scalar Arguments .. +* INTEGER IDIST, N +* .. +* .. Array Arguments .. +* INTEGER ISEED( 4 ) +* DOUBLE PRECISION X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARNV returns a vector of n random real numbers from a uniform or +*> normal distribution. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] IDIST +*> \verbatim +*> IDIST is INTEGER +*> Specifies the distribution of the random numbers: +*> = 1: uniform (0,1) +*> = 2: uniform (-1,1) +*> = 3: normal (0,1) +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry, the seed of the random number generator; the array +*> elements must be between 0 and 4095, and ISEED(4) must be +*> odd. +*> On exit, the seed is updated. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of random numbers to be generated. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (N) +*> The generated random numbers. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> This routine calls the auxiliary routine DLARUV to generate random +*> real numbers from a uniform (0,1) distribution, in batches of up to +*> 128 using vectorisable code. The Box-Muller method is used to +*> transform numbers from a uniform to a normal distribution. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLARNV( IDIST, ISEED, N, X ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IDIST, N +* .. +* .. Array Arguments .. + INTEGER ISEED( 4 ) + DOUBLE PRECISION X( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, TWO + PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) + INTEGER LV + PARAMETER ( LV = 128 ) + DOUBLE PRECISION TWOPI + PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IL, IL2, IV +* .. +* .. Local Arrays .. + DOUBLE PRECISION U( LV ) +* .. +* .. Intrinsic Functions .. + INTRINSIC COS, LOG, MIN, SQRT +* .. +* .. External Subroutines .. + EXTERNAL DLARUV +* .. +* .. Executable Statements .. +* + DO 40 IV = 1, N, LV / 2 + IL = MIN( LV / 2, N-IV+1 ) + IF( IDIST.EQ.3 ) THEN + IL2 = 2*IL + ELSE + IL2 = IL + END IF +* +* Call DLARUV to generate IL2 numbers from a uniform (0,1) +* distribution (IL2 <= LV) +* + CALL DLARUV( ISEED, IL2, U ) +* + IF( IDIST.EQ.1 ) THEN +* +* Copy generated numbers +* + DO 10 I = 1, IL + X( IV+I-1 ) = U( I ) + 10 CONTINUE + ELSE IF( IDIST.EQ.2 ) THEN +* +* Convert generated numbers to uniform (-1,1) distribution +* + DO 20 I = 1, IL + X( IV+I-1 ) = TWO*U( I ) - ONE + 20 CONTINUE + ELSE IF( IDIST.EQ.3 ) THEN +* +* Convert generated numbers to normal (0,1) distribution +* + DO 30 I = 1, IL + X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* + $ COS( TWOPI*U( 2*I ) ) + 30 CONTINUE + END IF + 40 CONTINUE + RETURN +* +* End of DLARNV +* + END diff --git a/math/lapack/src/main/fortran/dlarra.f b/math/lapack/src/main/fortran/dlarra.f new file mode 100644 index 0000000000..31a0bfbbc6 --- /dev/null +++ b/math/lapack/src/main/fortran/dlarra.f @@ -0,0 +1,204 @@ +*> \brief \b DLARRA computes the splitting points with the specified threshold. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARRA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARRA( N, D, E, E2, SPLTOL, TNRM, +* NSPLIT, ISPLIT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, N, NSPLIT +* DOUBLE PRECISION SPLTOL, TNRM +* .. +* .. Array Arguments .. +* INTEGER ISPLIT( * ) +* DOUBLE PRECISION D( * ), E( * ), E2( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Compute the splitting points with threshold SPLTOL. +*> DLARRA sets any "small" off-diagonal elements to zero. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N > 0. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the N diagonal elements of the tridiagonal +*> matrix T. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On entry, the first (N-1) entries contain the subdiagonal +*> elements of the tridiagonal matrix T; E(N) need not be set. +*> On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT, +*> are set to zero, the other entries of E are untouched. +*> \endverbatim +*> +*> \param[in,out] E2 +*> \verbatim +*> E2 is DOUBLE PRECISION array, dimension (N) +*> On entry, the first (N-1) entries contain the SQUARES of the +*> subdiagonal elements of the tridiagonal matrix T; +*> E2(N) need not be set. +*> On exit, the entries E2( ISPLIT( I ) ), +*> 1 <= I <= NSPLIT, have been set to zero +*> \endverbatim +*> +*> \param[in] SPLTOL +*> \verbatim +*> SPLTOL is DOUBLE PRECISION +*> The threshold for splitting. Two criteria can be used: +*> SPLTOL<0 : criterion based on absolute off-diagonal value +*> SPLTOL>0 : criterion that preserves relative accuracy +*> \endverbatim +*> +*> \param[in] TNRM +*> \verbatim +*> TNRM is DOUBLE PRECISION +*> The norm of the matrix. +*> \endverbatim +*> +*> \param[out] NSPLIT +*> \verbatim +*> NSPLIT is INTEGER +*> The number of blocks T splits into. 1 <= NSPLIT <= N. +*> \endverbatim +*> +*> \param[out] ISPLIT +*> \verbatim +*> ISPLIT is INTEGER array, dimension (N) +*> The splitting points, at which T breaks up into blocks. +*> The first block consists of rows/columns 1 to ISPLIT(1), +*> the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), +*> etc., and the NSPLIT-th consists of rows/columns +*> ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Beresford Parlett, University of California, Berkeley, USA \n +*> Jim Demmel, University of California, Berkeley, USA \n +*> Inderjit Dhillon, University of Texas, Austin, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Christof Voemel, University of California, Berkeley, USA +* +* ===================================================================== + SUBROUTINE DLARRA( N, D, E, E2, SPLTOL, TNRM, + $ NSPLIT, ISPLIT, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, N, NSPLIT + DOUBLE PRECISION SPLTOL, TNRM +* .. +* .. Array Arguments .. + INTEGER ISPLIT( * ) + DOUBLE PRECISION D( * ), E( * ), E2( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION EABS, TMP1 + +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + INFO = 0 + +* Compute splitting points + NSPLIT = 1 + IF(SPLTOL.LT.ZERO) THEN +* Criterion based on absolute off-diagonal value + TMP1 = ABS(SPLTOL)* TNRM + DO 9 I = 1, N-1 + EABS = ABS( E(I) ) + IF( EABS .LE. TMP1) THEN + E(I) = ZERO + E2(I) = ZERO + ISPLIT( NSPLIT ) = I + NSPLIT = NSPLIT + 1 + END IF + 9 CONTINUE + ELSE +* Criterion that guarantees relative accuracy + DO 10 I = 1, N-1 + EABS = ABS( E(I) ) + IF( EABS .LE. SPLTOL * SQRT(ABS(D(I)))*SQRT(ABS(D(I+1))) ) + $ THEN + E(I) = ZERO + E2(I) = ZERO + ISPLIT( NSPLIT ) = I + NSPLIT = NSPLIT + 1 + END IF + 10 CONTINUE + ENDIF + ISPLIT( NSPLIT ) = N + + RETURN +* +* End of DLARRA +* + END diff --git a/math/lapack/src/main/fortran/dlarrb.f b/math/lapack/src/main/fortran/dlarrb.f new file mode 100644 index 0000000000..68d6ade9ab --- /dev/null +++ b/math/lapack/src/main/fortran/dlarrb.f @@ -0,0 +1,401 @@ +*> \brief \b DLARRB provides limited bisection to locate eigenvalues for more accuracy. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARRB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, +* RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, +* PIVMIN, SPDIAM, TWIST, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST +* DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPDIAM +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION D( * ), LLD( * ), W( * ), +* $ WERR( * ), WGAP( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Given the relatively robust representation(RRR) L D L^T, DLARRB +*> does "limited" bisection to refine the eigenvalues of L D L^T, +*> W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial +*> guesses for these eigenvalues are input in W, the corresponding estimate +*> of the error in these guesses and their gaps are input in WERR +*> and WGAP, respectively. During bisection, intervals +*> [left, right] are maintained by storing their mid-points and +*> semi-widths in the arrays W and WERR respectively. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The N diagonal elements of the diagonal matrix D. +*> \endverbatim +*> +*> \param[in] LLD +*> \verbatim +*> LLD is DOUBLE PRECISION array, dimension (N-1) +*> The (N-1) elements L(i)*L(i)*D(i). +*> \endverbatim +*> +*> \param[in] IFIRST +*> \verbatim +*> IFIRST is INTEGER +*> The index of the first eigenvalue to be computed. +*> \endverbatim +*> +*> \param[in] ILAST +*> \verbatim +*> ILAST is INTEGER +*> The index of the last eigenvalue to be computed. +*> \endverbatim +*> +*> \param[in] RTOL1 +*> \verbatim +*> RTOL1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] RTOL2 +*> \verbatim +*> RTOL2 is DOUBLE PRECISION +*> Tolerance for the convergence of the bisection intervals. +*> An interval [LEFT,RIGHT] has converged if +*> RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) +*> where GAP is the (estimated) distance to the nearest +*> eigenvalue. +*> \endverbatim +*> +*> \param[in] OFFSET +*> \verbatim +*> OFFSET is INTEGER +*> Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET +*> through ILAST-OFFSET elements of these arrays are to be used. +*> \endverbatim +*> +*> \param[in,out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are +*> estimates of the eigenvalues of L D L^T indexed IFIRST throug +*> ILAST. +*> On output, these estimates are refined. +*> \endverbatim +*> +*> \param[in,out] WGAP +*> \verbatim +*> WGAP is DOUBLE PRECISION array, dimension (N-1) +*> On input, the (estimated) gaps between consecutive +*> eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between +*> eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST +*> then WGAP(IFIRST-OFFSET) must be set to ZERO. +*> On output, these gaps are refined. +*> \endverbatim +*> +*> \param[in,out] WERR +*> \verbatim +*> WERR is DOUBLE PRECISION array, dimension (N) +*> On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are +*> the errors in the estimates of the corresponding elements in W. +*> On output, these errors are refined. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> Workspace. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*N) +*> Workspace. +*> \endverbatim +*> +*> \param[in] PIVMIN +*> \verbatim +*> PIVMIN is DOUBLE PRECISION +*> The minimum pivot in the Sturm sequence. +*> \endverbatim +*> +*> \param[in] SPDIAM +*> \verbatim +*> SPDIAM is DOUBLE PRECISION +*> The spectral diameter of the matrix. +*> \endverbatim +*> +*> \param[in] TWIST +*> \verbatim +*> TWIST is INTEGER +*> The twist index for the twisted factorization that is used +*> for the negcount. +*> TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T +*> TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T +*> TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> Error flag. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Beresford Parlett, University of California, Berkeley, USA \n +*> Jim Demmel, University of California, Berkeley, USA \n +*> Inderjit Dhillon, University of Texas, Austin, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Christof Voemel, University of California, Berkeley, USA +* +* ===================================================================== + SUBROUTINE DLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, + $ RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, + $ PIVMIN, SPDIAM, TWIST, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST + DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPDIAM +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION D( * ), LLD( * ), W( * ), + $ WERR( * ), WGAP( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, TWO, HALF + PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0, + $ HALF = 0.5D0 ) + INTEGER MAXITR +* .. +* .. Local Scalars .. + INTEGER I, I1, II, IP, ITER, K, NEGCNT, NEXT, NINT, + $ OLNINT, PREV, R + DOUBLE PRECISION BACK, CVRGD, GAP, LEFT, LGAP, MID, MNWDTH, + $ RGAP, RIGHT, TMP, WIDTH +* .. +* .. External Functions .. + INTEGER DLANEG + EXTERNAL DLANEG +* +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 +* + MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) / + $ LOG( TWO ) ) + 2 + MNWDTH = TWO * PIVMIN +* + R = TWIST + IF((R.LT.1).OR.(R.GT.N)) R = N +* +* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. +* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while +* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) +* for an unconverged interval is set to the index of the next unconverged +* interval, and is -1 or 0 for a converged interval. Thus a linked +* list of unconverged intervals is set up. +* + I1 = IFIRST +* The number of unconverged intervals + NINT = 0 +* The last unconverged interval found + PREV = 0 + + RGAP = WGAP( I1-OFFSET ) + DO 75 I = I1, ILAST + K = 2*I + II = I - OFFSET + LEFT = W( II ) - WERR( II ) + RIGHT = W( II ) + WERR( II ) + LGAP = RGAP + RGAP = WGAP( II ) + GAP = MIN( LGAP, RGAP ) + +* Make sure that [LEFT,RIGHT] contains the desired eigenvalue +* Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT +* +* Do while( NEGCNT(LEFT).GT.I-1 ) +* + BACK = WERR( II ) + 20 CONTINUE + NEGCNT = DLANEG( N, D, LLD, LEFT, PIVMIN, R ) + IF( NEGCNT.GT.I-1 ) THEN + LEFT = LEFT - BACK + BACK = TWO*BACK + GO TO 20 + END IF +* +* Do while( NEGCNT(RIGHT).LT.I ) +* Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT +* + BACK = WERR( II ) + 50 CONTINUE + + NEGCNT = DLANEG( N, D, LLD, RIGHT, PIVMIN, R ) + IF( NEGCNT.LT.I ) THEN + RIGHT = RIGHT + BACK + BACK = TWO*BACK + GO TO 50 + END IF + WIDTH = HALF*ABS( LEFT - RIGHT ) + TMP = MAX( ABS( LEFT ), ABS( RIGHT ) ) + CVRGD = MAX(RTOL1*GAP,RTOL2*TMP) + IF( WIDTH.LE.CVRGD .OR. WIDTH.LE.MNWDTH ) THEN +* This interval has already converged and does not need refinement. +* (Note that the gaps might change through refining the +* eigenvalues, however, they can only get bigger.) +* Remove it from the list. + IWORK( K-1 ) = -1 +* Make sure that I1 always points to the first unconverged interval + IF((I.EQ.I1).AND.(I.LT.ILAST)) I1 = I + 1 + IF((PREV.GE.I1).AND.(I.LE.ILAST)) IWORK( 2*PREV-1 ) = I + 1 + ELSE +* unconverged interval found + PREV = I + NINT = NINT + 1 + IWORK( K-1 ) = I + 1 + IWORK( K ) = NEGCNT + END IF + WORK( K-1 ) = LEFT + WORK( K ) = RIGHT + 75 CONTINUE + +* +* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals +* and while (ITER.LT.MAXITR) +* + ITER = 0 + 80 CONTINUE + PREV = I1 - 1 + I = I1 + OLNINT = NINT + + DO 100 IP = 1, OLNINT + K = 2*I + II = I - OFFSET + RGAP = WGAP( II ) + LGAP = RGAP + IF(II.GT.1) LGAP = WGAP( II-1 ) + GAP = MIN( LGAP, RGAP ) + NEXT = IWORK( K-1 ) + LEFT = WORK( K-1 ) + RIGHT = WORK( K ) + MID = HALF*( LEFT + RIGHT ) + +* semiwidth of interval + WIDTH = RIGHT - MID + TMP = MAX( ABS( LEFT ), ABS( RIGHT ) ) + CVRGD = MAX(RTOL1*GAP,RTOL2*TMP) + IF( ( WIDTH.LE.CVRGD ) .OR. ( WIDTH.LE.MNWDTH ).OR. + $ ( ITER.EQ.MAXITR ) )THEN +* reduce number of unconverged intervals + NINT = NINT - 1 +* Mark interval as converged. + IWORK( K-1 ) = 0 + IF( I1.EQ.I ) THEN + I1 = NEXT + ELSE +* Prev holds the last unconverged interval previously examined + IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT + END IF + I = NEXT + GO TO 100 + END IF + PREV = I +* +* Perform one bisection step +* + NEGCNT = DLANEG( N, D, LLD, MID, PIVMIN, R ) + IF( NEGCNT.LE.I-1 ) THEN + WORK( K-1 ) = MID + ELSE + WORK( K ) = MID + END IF + I = NEXT + 100 CONTINUE + ITER = ITER + 1 +* do another loop if there are still unconverged intervals +* However, in the last iteration, all intervals are accepted +* since this is the best we can do. + IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80 +* +* +* At this point, all the intervals have converged + DO 110 I = IFIRST, ILAST + K = 2*I + II = I - OFFSET +* All intervals marked by '0' have been refined. + IF( IWORK( K-1 ).EQ.0 ) THEN + W( II ) = HALF*( WORK( K-1 )+WORK( K ) ) + WERR( II ) = WORK( K ) - W( II ) + END IF + 110 CONTINUE +* + DO 111 I = IFIRST+1, ILAST + K = 2*I + II = I - OFFSET + WGAP( II-1 ) = MAX( ZERO, + $ W(II) - WERR (II) - W( II-1 ) - WERR( II-1 )) + 111 CONTINUE + + RETURN +* +* End of DLARRB +* + END diff --git a/math/lapack/src/main/fortran/dlarrc.f b/math/lapack/src/main/fortran/dlarrc.f new file mode 100644 index 0000000000..9635e41225 --- /dev/null +++ b/math/lapack/src/main/fortran/dlarrc.f @@ -0,0 +1,244 @@ +*> \brief \b DLARRC computes the number of eigenvalues of the symmetric tridiagonal matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARRC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN, +* EIGCNT, LCNT, RCNT, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBT +* INTEGER EIGCNT, INFO, LCNT, N, RCNT +* DOUBLE PRECISION PIVMIN, VL, VU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Find the number of eigenvalues of the symmetric tridiagonal matrix T +*> that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T +*> if JOBT = 'L'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBT +*> \verbatim +*> JOBT is CHARACTER*1 +*> = 'T': Compute Sturm count for matrix T. +*> = 'L': Compute Sturm count for matrix L D L^T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N > 0. +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> The lower bound for the eigenvalues. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> The upper bound for the eigenvalues. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> JOBT = 'T': The N diagonal elements of the tridiagonal matrix T. +*> JOBT = 'L': The N diagonal elements of the diagonal matrix D. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> JOBT = 'T': The N-1 offdiagonal elements of the matrix T. +*> JOBT = 'L': The N-1 offdiagonal elements of the matrix L. +*> \endverbatim +*> +*> \param[in] PIVMIN +*> \verbatim +*> PIVMIN is DOUBLE PRECISION +*> The minimum pivot in the Sturm sequence for T. +*> \endverbatim +*> +*> \param[out] EIGCNT +*> \verbatim +*> EIGCNT is INTEGER +*> The number of eigenvalues of the symmetric tridiagonal matrix T +*> that are in the interval (VL,VU] +*> \endverbatim +*> +*> \param[out] LCNT +*> \verbatim +*> LCNT is INTEGER +*> \endverbatim +*> +*> \param[out] RCNT +*> \verbatim +*> RCNT is INTEGER +*> The left and right negcounts of the interval. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Beresford Parlett, University of California, Berkeley, USA \n +*> Jim Demmel, University of California, Berkeley, USA \n +*> Inderjit Dhillon, University of Texas, Austin, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Christof Voemel, University of California, Berkeley, USA +* +* ===================================================================== + SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN, + $ EIGCNT, LCNT, RCNT, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBT + INTEGER EIGCNT, INFO, LCNT, N, RCNT + DOUBLE PRECISION PIVMIN, VL, VU +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I + LOGICAL MATT + DOUBLE PRECISION LPIVOT, RPIVOT, SL, SU, TMP, TMP2 + +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* + INFO = 0 + LCNT = 0 + RCNT = 0 + EIGCNT = 0 + MATT = LSAME( JOBT, 'T' ) + + + IF (MATT) THEN +* Sturm sequence count on T + LPIVOT = D( 1 ) - VL + RPIVOT = D( 1 ) - VU + IF( LPIVOT.LE.ZERO ) THEN + LCNT = LCNT + 1 + ENDIF + IF( RPIVOT.LE.ZERO ) THEN + RCNT = RCNT + 1 + ENDIF + DO 10 I = 1, N-1 + TMP = E(I)**2 + LPIVOT = ( D( I+1 )-VL ) - TMP/LPIVOT + RPIVOT = ( D( I+1 )-VU ) - TMP/RPIVOT + IF( LPIVOT.LE.ZERO ) THEN + LCNT = LCNT + 1 + ENDIF + IF( RPIVOT.LE.ZERO ) THEN + RCNT = RCNT + 1 + ENDIF + 10 CONTINUE + ELSE +* Sturm sequence count on L D L^T + SL = -VL + SU = -VU + DO 20 I = 1, N - 1 + LPIVOT = D( I ) + SL + RPIVOT = D( I ) + SU + IF( LPIVOT.LE.ZERO ) THEN + LCNT = LCNT + 1 + ENDIF + IF( RPIVOT.LE.ZERO ) THEN + RCNT = RCNT + 1 + ENDIF + TMP = E(I) * D(I) * E(I) +* + TMP2 = TMP / LPIVOT + IF( TMP2.EQ.ZERO ) THEN + SL = TMP - VL + ELSE + SL = SL*TMP2 - VL + END IF +* + TMP2 = TMP / RPIVOT + IF( TMP2.EQ.ZERO ) THEN + SU = TMP - VU + ELSE + SU = SU*TMP2 - VU + END IF + 20 CONTINUE + LPIVOT = D( N ) + SL + RPIVOT = D( N ) + SU + IF( LPIVOT.LE.ZERO ) THEN + LCNT = LCNT + 1 + ENDIF + IF( RPIVOT.LE.ZERO ) THEN + RCNT = RCNT + 1 + ENDIF + ENDIF + EIGCNT = RCNT - LCNT + + RETURN +* +* end of DLARRC +* + END diff --git a/math/lapack/src/main/fortran/dlarrd.f b/math/lapack/src/main/fortran/dlarrd.f new file mode 100644 index 0000000000..57abf74365 --- /dev/null +++ b/math/lapack/src/main/fortran/dlarrd.f @@ -0,0 +1,863 @@ +*> \brief \b DLARRD computes the eigenvalues of a symmetric tridiagonal matrix to suitable accuracy. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, +* RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, +* M, W, WERR, WL, WU, IBLOCK, INDEXW, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER ORDER, RANGE +* INTEGER IL, INFO, IU, M, N, NSPLIT +* DOUBLE PRECISION PIVMIN, RELTOL, VL, VU, WL, WU +* .. +* .. Array Arguments .. +* INTEGER IBLOCK( * ), INDEXW( * ), +* $ ISPLIT( * ), IWORK( * ) +* DOUBLE PRECISION D( * ), E( * ), E2( * ), +* $ GERS( * ), W( * ), WERR( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARRD computes the eigenvalues of a symmetric tridiagonal +*> matrix T to suitable accuracy. This is an auxiliary code to be +*> called from DSTEMR. +*> The user may ask for all eigenvalues, all eigenvalues +*> in the half-open interval (VL, VU], or the IL-th through IU-th +*> eigenvalues. +*> +*> To avoid overflow, the matrix must be scaled so that its +*> largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest +*> accuracy, it should not be much smaller than that. +*> +*> See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal +*> Matrix", Report CS41, Computer Science Dept., Stanford +*> University, July 21, 1966. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': ("All") all eigenvalues will be found. +*> = 'V': ("Value") all eigenvalues in the half-open interval +*> (VL, VU] will be found. +*> = 'I': ("Index") the IL-th through IU-th eigenvalues (of the +*> entire matrix) will be found. +*> \endverbatim +*> +*> \param[in] ORDER +*> \verbatim +*> ORDER is CHARACTER*1 +*> = 'B': ("By Block") the eigenvalues will be grouped by +*> split-off block (see IBLOCK, ISPLIT) and +*> ordered from smallest to largest within +*> the block. +*> = 'E': ("Entire matrix") +*> the eigenvalues for the entire matrix +*> will be ordered from smallest to +*> largest. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the tridiagonal matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. Eigenvalues less than or equal +*> to VL, or greater than VU, will not be returned. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. Eigenvalues less than or equal +*> to VL, or greater than VU, will not be returned. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] GERS +*> \verbatim +*> GERS is DOUBLE PRECISION array, dimension (2*N) +*> The N Gerschgorin intervals (the i-th Gerschgorin interval +*> is (GERS(2*i-1), GERS(2*i)). +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION +*> The minimum relative width of an interval. When an interval +*> is narrower than RELTOL times the larger (in +*> magnitude) endpoint, then it is considered to be +*> sufficiently small, i.e., converged. Note: this should +*> always be at least radix*machine epsilon. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) off-diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[in] E2 +*> \verbatim +*> E2 is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) squared off-diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[in] PIVMIN +*> \verbatim +*> PIVMIN is DOUBLE PRECISION +*> The minimum pivot allowed in the Sturm sequence for T. +*> \endverbatim +*> +*> \param[in] NSPLIT +*> \verbatim +*> NSPLIT is INTEGER +*> The number of diagonal blocks in the matrix T. +*> 1 <= NSPLIT <= N. +*> \endverbatim +*> +*> \param[in] ISPLIT +*> \verbatim +*> ISPLIT is INTEGER array, dimension (N) +*> The splitting points, at which T breaks up into submatrices. +*> The first submatrix consists of rows/columns 1 to ISPLIT(1), +*> the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), +*> etc., and the NSPLIT-th consists of rows/columns +*> ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. +*> (Only the first NSPLIT elements will actually be used, but +*> since the user cannot know a priori what value NSPLIT will +*> have, N words must be reserved for ISPLIT.) +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The actual number of eigenvalues found. 0 <= M <= N. +*> (See also the description of INFO=2,3.) +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> On exit, the first M elements of W will contain the +*> eigenvalue approximations. DLARRD computes an interval +*> I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue +*> approximation is given as the interval midpoint +*> W(j)= ( a_j + b_j)/2. The corresponding error is bounded by +*> WERR(j) = abs( a_j - b_j)/2 +*> \endverbatim +*> +*> \param[out] WERR +*> \verbatim +*> WERR is DOUBLE PRECISION array, dimension (N) +*> The error bound on the corresponding eigenvalue approximation +*> in W. +*> \endverbatim +*> +*> \param[out] WL +*> \verbatim +*> WL is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] WU +*> \verbatim +*> WU is DOUBLE PRECISION +*> The interval (WL, WU] contains all the wanted eigenvalues. +*> If RANGE='V', then WL=VL and WU=VU. +*> If RANGE='A', then WL and WU are the global Gerschgorin bounds +*> on the spectrum. +*> If RANGE='I', then WL and WU are computed by DLAEBZ from the +*> index range specified. +*> \endverbatim +*> +*> \param[out] IBLOCK +*> \verbatim +*> IBLOCK is INTEGER array, dimension (N) +*> At each row/column j where E(j) is zero or small, the +*> matrix T is considered to split into a block diagonal +*> matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which +*> block (from 1 to the number of blocks) the eigenvalue W(i) +*> belongs. (DLARRD may use the remaining N-M elements as +*> workspace.) +*> \endverbatim +*> +*> \param[out] INDEXW +*> \verbatim +*> INDEXW is INTEGER array, dimension (N) +*> The indices of the eigenvalues within each block (submatrix); +*> for example, INDEXW(i)= j and IBLOCK(i)=k imply that the +*> i-th eigenvalue W(i) is the j-th eigenvalue in block k. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: some or all of the eigenvalues failed to converge or +*> were not computed: +*> =1 or 3: Bisection failed to converge for some +*> eigenvalues; these eigenvalues are flagged by a +*> negative block number. The effect is that the +*> eigenvalues may not be as accurate as the +*> absolute and relative tolerances. This is +*> generally caused by unexpectedly inaccurate +*> arithmetic. +*> =2 or 3: RANGE='I' only: Not all of the eigenvalues +*> IL:IU were found. +*> Effect: M < IU+1-IL +*> Cause: non-monotonic arithmetic, causing the +*> Sturm sequence to be non-monotonic. +*> Cure: recalculate, using RANGE='A', and pick +*> out eigenvalues IL:IU. In some cases, +*> increasing the PARAMETER "FUDGE" may +*> make things work. +*> = 4: RANGE='I', and the Gershgorin interval +*> initially used was too small. No eigenvalues +*> were computed. +*> Probable cause: your machine has sloppy +*> floating-point arithmetic. +*> Cure: Increase the PARAMETER "FUDGE", +*> recompile, and try again. +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> FUDGE DOUBLE PRECISION, default = 2 +*> A "fudge factor" to widen the Gershgorin intervals. Ideally, +*> a value of 1 should work, but on machines with sloppy +*> arithmetic, this needs to be larger. The default for +*> publicly released versions should be large enough to handle +*> the worst machine around. Note that this has no effect +*> on accuracy of the solution. +*> \endverbatim +*> +*> \par Contributors: +* ================== +*> +*> W. Kahan, University of California, Berkeley, USA \n +*> Beresford Parlett, University of California, Berkeley, USA \n +*> Jim Demmel, University of California, Berkeley, USA \n +*> Inderjit Dhillon, University of Texas, Austin, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Christof Voemel, University of California, Berkeley, USA \n +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, + $ RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, + $ M, W, WERR, WL, WU, IBLOCK, INDEXW, + $ WORK, IWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER ORDER, RANGE + INTEGER IL, INFO, IU, M, N, NSPLIT + DOUBLE PRECISION PIVMIN, RELTOL, VL, VU, WL, WU +* .. +* .. Array Arguments .. + INTEGER IBLOCK( * ), INDEXW( * ), + $ ISPLIT( * ), IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), E2( * ), + $ GERS( * ), W( * ), WERR( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, HALF, FUDGE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, + $ TWO = 2.0D0, HALF = ONE/TWO, + $ FUDGE = TWO ) + INTEGER ALLRNG, VALRNG, INDRNG + PARAMETER ( ALLRNG = 1, VALRNG = 2, INDRNG = 3 ) +* .. +* .. Local Scalars .. + LOGICAL NCNVRG, TOOFEW + INTEGER I, IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO, + $ IM, IN, IOFF, IOUT, IRANGE, ITMAX, ITMP1, + $ ITMP2, IW, IWOFF, J, JBLK, JDISC, JE, JEE, NB, + $ NWL, NWU + DOUBLE PRECISION ATOLI, EPS, GL, GU, RTOLI, TMP1, TMP2, + $ TNORM, UFLOW, WKILL, WLU, WUL + +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, ILAENV, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLAEBZ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, INT, LOG, MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Decode RANGE +* + IF( LSAME( RANGE, 'A' ) ) THEN + IRANGE = ALLRNG + ELSE IF( LSAME( RANGE, 'V' ) ) THEN + IRANGE = VALRNG + ELSE IF( LSAME( RANGE, 'I' ) ) THEN + IRANGE = INDRNG + ELSE + IRANGE = 0 + END IF +* +* Check for Errors +* + IF( IRANGE.LE.0 ) THEN + INFO = -1 + ELSE IF( .NOT.(LSAME(ORDER,'B').OR.LSAME(ORDER,'E')) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( IRANGE.EQ.VALRNG ) THEN + IF( VL.GE.VU ) + $ INFO = -5 + ELSE IF( IRANGE.EQ.INDRNG .AND. + $ ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) THEN + INFO = -6 + ELSE IF( IRANGE.EQ.INDRNG .AND. + $ ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN + INFO = -7 + END IF +* + IF( INFO.NE.0 ) THEN + RETURN + END IF + +* Initialize error flags + INFO = 0 + NCNVRG = .FALSE. + TOOFEW = .FALSE. + +* Quick return if possible + M = 0 + IF( N.EQ.0 ) RETURN + +* Simplification: + IF( IRANGE.EQ.INDRNG .AND. IL.EQ.1 .AND. IU.EQ.N ) IRANGE = 1 + +* Get machine constants + EPS = DLAMCH( 'P' ) + UFLOW = DLAMCH( 'U' ) + + +* Special Case when N=1 +* Treat case of 1x1 matrix for quick return + IF( N.EQ.1 ) THEN + IF( (IRANGE.EQ.ALLRNG).OR. + $ ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR. + $ ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN + M = 1 + W(1) = D(1) +* The computation error of the eigenvalue is zero + WERR(1) = ZERO + IBLOCK( 1 ) = 1 + INDEXW( 1 ) = 1 + ENDIF + RETURN + END IF + +* NB is the minimum vector length for vector bisection, or 0 +* if only scalar is to be done. + NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 ) + IF( NB.LE.1 ) NB = 0 + +* Find global spectral radius + GL = D(1) + GU = D(1) + DO 5 I = 1,N + GL = MIN( GL, GERS( 2*I - 1)) + GU = MAX( GU, GERS(2*I) ) + 5 CONTINUE +* Compute global Gerschgorin bounds and spectral diameter + TNORM = MAX( ABS( GL ), ABS( GU ) ) + GL = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN + GU = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN +* [JAN/28/2009] remove the line below since SPDIAM variable not use +* SPDIAM = GU - GL +* Input arguments for DLAEBZ: +* The relative tolerance. An interval (a,b] lies within +* "relative tolerance" if b-a < RELTOL*max(|a|,|b|), + RTOLI = RELTOL +* Set the absolute tolerance for interval convergence to zero to force +* interval convergence based on relative size of the interval. +* This is dangerous because intervals might not converge when RELTOL is +* small. But at least a very small number should be selected so that for +* strongly graded matrices, the code can get relatively accurate +* eigenvalues. + ATOLI = FUDGE*TWO*UFLOW + FUDGE*TWO*PIVMIN + + IF( IRANGE.EQ.INDRNG ) THEN + +* RANGE='I': Compute an interval containing eigenvalues +* IL through IU. The initial interval [GL,GU] from the global +* Gerschgorin bounds GL and GU is refined by DLAEBZ. + ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) / + $ LOG( TWO ) ) + 2 + WORK( N+1 ) = GL + WORK( N+2 ) = GL + WORK( N+3 ) = GU + WORK( N+4 ) = GU + WORK( N+5 ) = GL + WORK( N+6 ) = GU + IWORK( 1 ) = -1 + IWORK( 2 ) = -1 + IWORK( 3 ) = N + 1 + IWORK( 4 ) = N + 1 + IWORK( 5 ) = IL - 1 + IWORK( 6 ) = IU +* + CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, + $ D, E, E2, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT, + $ IWORK, W, IBLOCK, IINFO ) + IF( IINFO .NE. 0 ) THEN + INFO = IINFO + RETURN + END IF +* On exit, output intervals may not be ordered by ascending negcount + IF( IWORK( 6 ).EQ.IU ) THEN + WL = WORK( N+1 ) + WLU = WORK( N+3 ) + NWL = IWORK( 1 ) + WU = WORK( N+4 ) + WUL = WORK( N+2 ) + NWU = IWORK( 4 ) + ELSE + WL = WORK( N+2 ) + WLU = WORK( N+4 ) + NWL = IWORK( 2 ) + WU = WORK( N+3 ) + WUL = WORK( N+1 ) + NWU = IWORK( 3 ) + END IF +* On exit, the interval [WL, WLU] contains a value with negcount NWL, +* and [WUL, WU] contains a value with negcount NWU. + IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN + INFO = 4 + RETURN + END IF + + ELSEIF( IRANGE.EQ.VALRNG ) THEN + WL = VL + WU = VU + + ELSEIF( IRANGE.EQ.ALLRNG ) THEN + WL = GL + WU = GU + ENDIF + + + +* Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU. +* NWL accumulates the number of eigenvalues .le. WL, +* NWU accumulates the number of eigenvalues .le. WU + M = 0 + IEND = 0 + INFO = 0 + NWL = 0 + NWU = 0 +* + DO 70 JBLK = 1, NSPLIT + IOFF = IEND + IBEGIN = IOFF + 1 + IEND = ISPLIT( JBLK ) + IN = IEND - IOFF +* + IF( IN.EQ.1 ) THEN +* 1x1 block + IF( WL.GE.D( IBEGIN )-PIVMIN ) + $ NWL = NWL + 1 + IF( WU.GE.D( IBEGIN )-PIVMIN ) + $ NWU = NWU + 1 + IF( IRANGE.EQ.ALLRNG .OR. + $ ( WL.LT.D( IBEGIN )-PIVMIN + $ .AND. WU.GE. D( IBEGIN )-PIVMIN ) ) THEN + M = M + 1 + W( M ) = D( IBEGIN ) + WERR(M) = ZERO +* The gap for a single block doesn't matter for the later +* algorithm and is assigned an arbitrary large value + IBLOCK( M ) = JBLK + INDEXW( M ) = 1 + END IF + +* Disabled 2x2 case because of a failure on the following matrix +* RANGE = 'I', IL = IU = 4 +* Original Tridiagonal, d = [ +* -0.150102010615740E+00 +* -0.849897989384260E+00 +* -0.128208148052635E-15 +* 0.128257718286320E-15 +* ]; +* e = [ +* -0.357171383266986E+00 +* -0.180411241501588E-15 +* -0.175152352710251E-15 +* ]; +* +* ELSE IF( IN.EQ.2 ) THEN +** 2x2 block +* DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 ) +* TMP1 = HALF*(D(IBEGIN)+D(IEND)) +* L1 = TMP1 - DISC +* IF( WL.GE. L1-PIVMIN ) +* $ NWL = NWL + 1 +* IF( WU.GE. L1-PIVMIN ) +* $ NWU = NWU + 1 +* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE. +* $ L1-PIVMIN ) ) THEN +* M = M + 1 +* W( M ) = L1 +** The uncertainty of eigenvalues of a 2x2 matrix is very small +* WERR( M ) = EPS * ABS( W( M ) ) * TWO +* IBLOCK( M ) = JBLK +* INDEXW( M ) = 1 +* ENDIF +* L2 = TMP1 + DISC +* IF( WL.GE. L2-PIVMIN ) +* $ NWL = NWL + 1 +* IF( WU.GE. L2-PIVMIN ) +* $ NWU = NWU + 1 +* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE. +* $ L2-PIVMIN ) ) THEN +* M = M + 1 +* W( M ) = L2 +** The uncertainty of eigenvalues of a 2x2 matrix is very small +* WERR( M ) = EPS * ABS( W( M ) ) * TWO +* IBLOCK( M ) = JBLK +* INDEXW( M ) = 2 +* ENDIF + ELSE +* General Case - block of size IN >= 2 +* Compute local Gerschgorin interval and use it as the initial +* interval for DLAEBZ + GU = D( IBEGIN ) + GL = D( IBEGIN ) + TMP1 = ZERO + + DO 40 J = IBEGIN, IEND + GL = MIN( GL, GERS( 2*J - 1)) + GU = MAX( GU, GERS(2*J) ) + 40 CONTINUE +* [JAN/28/2009] +* change SPDIAM by TNORM in lines 2 and 3 thereafter +* line 1: remove computation of SPDIAM (not useful anymore) +* SPDIAM = GU - GL +* GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN +* GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN + GL = GL - FUDGE*TNORM*EPS*IN - FUDGE*PIVMIN + GU = GU + FUDGE*TNORM*EPS*IN + FUDGE*PIVMIN +* + IF( IRANGE.GT.1 ) THEN + IF( GU.LT.WL ) THEN +* the local block contains none of the wanted eigenvalues + NWL = NWL + IN + NWU = NWU + IN + GO TO 70 + END IF +* refine search interval if possible, only range (WL,WU] matters + GL = MAX( GL, WL ) + GU = MIN( GU, WU ) + IF( GL.GE.GU ) + $ GO TO 70 + END IF + +* Find negcount of initial interval boundaries GL and GU + WORK( N+1 ) = GL + WORK( N+IN+1 ) = GU + CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, + $ D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ), + $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM, + $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) + IF( IINFO .NE. 0 ) THEN + INFO = IINFO + RETURN + END IF +* + NWL = NWL + IWORK( 1 ) + NWU = NWU + IWORK( IN+1 ) + IWOFF = M - IWORK( 1 ) + +* Compute Eigenvalues + ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) / + $ LOG( TWO ) ) + 2 + CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, + $ D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ), + $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT, + $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) + IF( IINFO .NE. 0 ) THEN + INFO = IINFO + RETURN + END IF +* +* Copy eigenvalues into W and IBLOCK +* Use -JBLK for block number for unconverged eigenvalues. +* Loop over the number of output intervals from DLAEBZ + DO 60 J = 1, IOUT +* eigenvalue approximation is middle point of interval + TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) ) +* semi length of error interval + TMP2 = HALF*ABS( WORK( J+N )-WORK( J+IN+N ) ) + IF( J.GT.IOUT-IINFO ) THEN +* Flag non-convergence. + NCNVRG = .TRUE. + IB = -JBLK + ELSE + IB = JBLK + END IF + DO 50 JE = IWORK( J ) + 1 + IWOFF, + $ IWORK( J+IN ) + IWOFF + W( JE ) = TMP1 + WERR( JE ) = TMP2 + INDEXW( JE ) = JE - IWOFF + IBLOCK( JE ) = IB + 50 CONTINUE + 60 CONTINUE +* + M = M + IM + END IF + 70 CONTINUE + +* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU +* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. + IF( IRANGE.EQ.INDRNG ) THEN + IDISCL = IL - 1 - NWL + IDISCU = NWU - IU +* + IF( IDISCL.GT.0 ) THEN + IM = 0 + DO 80 JE = 1, M +* Remove some of the smallest eigenvalues from the left so that +* at the end IDISCL =0. Move all eigenvalues up to the left. + IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN + IDISCL = IDISCL - 1 + ELSE + IM = IM + 1 + W( IM ) = W( JE ) + WERR( IM ) = WERR( JE ) + INDEXW( IM ) = INDEXW( JE ) + IBLOCK( IM ) = IBLOCK( JE ) + END IF + 80 CONTINUE + M = IM + END IF + IF( IDISCU.GT.0 ) THEN +* Remove some of the largest eigenvalues from the right so that +* at the end IDISCU =0. Move all eigenvalues up to the left. + IM=M+1 + DO 81 JE = M, 1, -1 + IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN + IDISCU = IDISCU - 1 + ELSE + IM = IM - 1 + W( IM ) = W( JE ) + WERR( IM ) = WERR( JE ) + INDEXW( IM ) = INDEXW( JE ) + IBLOCK( IM ) = IBLOCK( JE ) + END IF + 81 CONTINUE + JEE = 0 + DO 82 JE = IM, M + JEE = JEE + 1 + W( JEE ) = W( JE ) + WERR( JEE ) = WERR( JE ) + INDEXW( JEE ) = INDEXW( JE ) + IBLOCK( JEE ) = IBLOCK( JE ) + 82 CONTINUE + M = M-IM+1 + END IF + + IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN +* Code to deal with effects of bad arithmetic. (If N(w) is +* monotone non-decreasing, this should never happen.) +* Some low eigenvalues to be discarded are not in (WL,WLU], +* or high eigenvalues to be discarded are not in (WUL,WU] +* so just kill off the smallest IDISCL/largest IDISCU +* eigenvalues, by marking the corresponding IBLOCK = 0 + IF( IDISCL.GT.0 ) THEN + WKILL = WU + DO 100 JDISC = 1, IDISCL + IW = 0 + DO 90 JE = 1, M + IF( IBLOCK( JE ).NE.0 .AND. + $ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN + IW = JE + WKILL = W( JE ) + END IF + 90 CONTINUE + IBLOCK( IW ) = 0 + 100 CONTINUE + END IF + IF( IDISCU.GT.0 ) THEN + WKILL = WL + DO 120 JDISC = 1, IDISCU + IW = 0 + DO 110 JE = 1, M + IF( IBLOCK( JE ).NE.0 .AND. + $ ( W( JE ).GE.WKILL .OR. IW.EQ.0 ) ) THEN + IW = JE + WKILL = W( JE ) + END IF + 110 CONTINUE + IBLOCK( IW ) = 0 + 120 CONTINUE + END IF +* Now erase all eigenvalues with IBLOCK set to zero + IM = 0 + DO 130 JE = 1, M + IF( IBLOCK( JE ).NE.0 ) THEN + IM = IM + 1 + W( IM ) = W( JE ) + WERR( IM ) = WERR( JE ) + INDEXW( IM ) = INDEXW( JE ) + IBLOCK( IM ) = IBLOCK( JE ) + END IF + 130 CONTINUE + M = IM + END IF + IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN + TOOFEW = .TRUE. + END IF + END IF +* + IF(( IRANGE.EQ.ALLRNG .AND. M.NE.N ).OR. + $ ( IRANGE.EQ.INDRNG .AND. M.NE.IU-IL+1 ) ) THEN + TOOFEW = .TRUE. + END IF + +* If ORDER='B', do nothing the eigenvalues are already sorted by +* block. +* If ORDER='E', sort the eigenvalues from smallest to largest + + IF( LSAME(ORDER,'E') .AND. NSPLIT.GT.1 ) THEN + DO 150 JE = 1, M - 1 + IE = 0 + TMP1 = W( JE ) + DO 140 J = JE + 1, M + IF( W( J ).LT.TMP1 ) THEN + IE = J + TMP1 = W( J ) + END IF + 140 CONTINUE + IF( IE.NE.0 ) THEN + TMP2 = WERR( IE ) + ITMP1 = IBLOCK( IE ) + ITMP2 = INDEXW( IE ) + W( IE ) = W( JE ) + WERR( IE ) = WERR( JE ) + IBLOCK( IE ) = IBLOCK( JE ) + INDEXW( IE ) = INDEXW( JE ) + W( JE ) = TMP1 + WERR( JE ) = TMP2 + IBLOCK( JE ) = ITMP1 + INDEXW( JE ) = ITMP2 + END IF + 150 CONTINUE + END IF +* + INFO = 0 + IF( NCNVRG ) + $ INFO = INFO + 1 + IF( TOOFEW ) + $ INFO = INFO + 2 + RETURN +* +* End of DLARRD +* + END diff --git a/math/lapack/src/main/fortran/dlarre.f b/math/lapack/src/main/fortran/dlarre.f new file mode 100644 index 0000000000..f01b25f166 --- /dev/null +++ b/math/lapack/src/main/fortran/dlarre.f @@ -0,0 +1,899 @@ +*> \brief \b DLARRE given the tridiagonal matrix T, sets small off-diagonal elements to zero and for each unreduced block Ti, finds base representations and eigenvalues. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARRE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2, +* RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, +* W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER RANGE +* INTEGER IL, INFO, IU, M, N, NSPLIT +* DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ), +* $ INDEXW( * ) +* DOUBLE PRECISION D( * ), E( * ), E2( * ), GERS( * ), +* $ W( * ),WERR( * ), WGAP( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> To find the desired eigenvalues of a given real symmetric +*> tridiagonal matrix T, DLARRE sets any "small" off-diagonal +*> elements to zero, and for each unreduced block T_i, it finds +*> (a) a suitable shift at one end of the block's spectrum, +*> (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and +*> (c) eigenvalues of each L_i D_i L_i^T. +*> The representations and eigenvalues found are then used by +*> DSTEMR to compute the eigenvectors of T. +*> The accuracy varies depending on whether bisection is used to +*> find a few eigenvalues or the dqds algorithm (subroutine DLASQ2) to +*> conpute all and then discard any unwanted one. +*> As an added benefit, DLARRE also outputs the n +*> Gerschgorin intervals for the matrices L_i D_i L_i^T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': ("All") all eigenvalues will be found. +*> = 'V': ("Value") all eigenvalues in the half-open interval +*> (VL, VU] will be found. +*> = 'I': ("Index") the IL-th through IU-th eigenvalues (of the +*> entire matrix) will be found. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N > 0. +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound for the eigenvalues. +*> Eigenvalues less than or equal to VL, or greater than VU, +*> will not be returned. VL < VU. +*> If RANGE='I' or ='A', DLARRE computes bounds on the desired +*> part of the spectrum. +*> \endverbatim +*> +*> \param[in,out] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound for the eigenvalues. +*> Eigenvalues less than or equal to VL, or greater than VU, +*> will not be returned. VL < VU. +*> If RANGE='I' or ='A', DLARRE computes bounds on the desired +*> part of the spectrum. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the N diagonal elements of the tridiagonal +*> matrix T. +*> On exit, the N diagonal elements of the diagonal +*> matrices D_i. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On entry, the first (N-1) entries contain the subdiagonal +*> elements of the tridiagonal matrix T; E(N) need not be set. +*> On exit, E contains the subdiagonal elements of the unit +*> bidiagonal matrices L_i. The entries E( ISPLIT( I ) ), +*> 1 <= I <= NSPLIT, contain the base points sigma_i on output. +*> \endverbatim +*> +*> \param[in,out] E2 +*> \verbatim +*> E2 is DOUBLE PRECISION array, dimension (N) +*> On entry, the first (N-1) entries contain the SQUARES of the +*> subdiagonal elements of the tridiagonal matrix T; +*> E2(N) need not be set. +*> On exit, the entries E2( ISPLIT( I ) ), +*> 1 <= I <= NSPLIT, have been set to zero +*> \endverbatim +*> +*> \param[in] RTOL1 +*> \verbatim +*> RTOL1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] RTOL2 +*> \verbatim +*> RTOL2 is DOUBLE PRECISION +*> Parameters for bisection. +*> An interval [LEFT,RIGHT] has converged if +*> RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) +*> \endverbatim +*> +*> \param[in] SPLTOL +*> \verbatim +*> SPLTOL is DOUBLE PRECISION +*> The threshold for splitting. +*> \endverbatim +*> +*> \param[out] NSPLIT +*> \verbatim +*> NSPLIT is INTEGER +*> The number of blocks T splits into. 1 <= NSPLIT <= N. +*> \endverbatim +*> +*> \param[out] ISPLIT +*> \verbatim +*> ISPLIT is INTEGER array, dimension (N) +*> The splitting points, at which T breaks up into blocks. +*> The first block consists of rows/columns 1 to ISPLIT(1), +*> the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), +*> etc., and the NSPLIT-th consists of rows/columns +*> ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues (of all L_i D_i L_i^T) +*> found. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first M elements contain the eigenvalues. The +*> eigenvalues of each of the blocks, L_i D_i L_i^T, are +*> sorted in ascending order ( DLARRE may use the +*> remaining N-M elements as workspace). +*> \endverbatim +*> +*> \param[out] WERR +*> \verbatim +*> WERR is DOUBLE PRECISION array, dimension (N) +*> The error bound on the corresponding eigenvalue in W. +*> \endverbatim +*> +*> \param[out] WGAP +*> \verbatim +*> WGAP is DOUBLE PRECISION array, dimension (N) +*> The separation from the right neighbor eigenvalue in W. +*> The gap is only with respect to the eigenvalues of the same block +*> as each block has its own representation tree. +*> Exception: at the right end of a block we store the left gap +*> \endverbatim +*> +*> \param[out] IBLOCK +*> \verbatim +*> IBLOCK is INTEGER array, dimension (N) +*> The indices of the blocks (submatrices) associated with the +*> corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue +*> W(i) belongs to the first block from the top, =2 if W(i) +*> belongs to the second block, etc. +*> \endverbatim +*> +*> \param[out] INDEXW +*> \verbatim +*> INDEXW is INTEGER array, dimension (N) +*> The indices of the eigenvalues within each block (submatrix); +*> for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the +*> i-th eigenvalue W(i) is the 10-th eigenvalue in block 2 +*> \endverbatim +*> +*> \param[out] GERS +*> \verbatim +*> GERS is DOUBLE PRECISION array, dimension (2*N) +*> The N Gerschgorin intervals (the i-th Gerschgorin interval +*> is (GERS(2*i-1), GERS(2*i)). +*> \endverbatim +*> +*> \param[out] PIVMIN +*> \verbatim +*> PIVMIN is DOUBLE PRECISION +*> The minimum pivot in the Sturm sequence for T. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (6*N) +*> Workspace. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> Workspace. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> > 0: A problem occurred in DLARRE. +*> < 0: One of the called subroutines signaled an internal problem. +*> Needs inspection of the corresponding parameter IINFO +*> for further information. +*> +*> =-1: Problem in DLARRD. +*> = 2: No base representation could be found in MAXTRY iterations. +*> Increasing MAXTRY and recompilation might be a remedy. +*> =-3: Problem in DLARRB when computing the refined root +*> representation for DLASQ2. +*> =-4: Problem in DLARRB when preforming bisection on the +*> desired part of the spectrum. +*> =-5: Problem in DLASQ2. +*> =-6: Problem in DLASQ2. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The base representations are required to suffer very little +*> element growth and consequently define all their eigenvalues to +*> high relative accuracy. +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> Beresford Parlett, University of California, Berkeley, USA \n +*> Jim Demmel, University of California, Berkeley, USA \n +*> Inderjit Dhillon, University of Texas, Austin, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Christof Voemel, University of California, Berkeley, USA \n +*> +* ===================================================================== + SUBROUTINE DLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2, + $ RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, + $ W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, + $ WORK, IWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER RANGE + INTEGER IL, INFO, IU, M, N, NSPLIT + DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ), + $ INDEXW( * ) + DOUBLE PRECISION D( * ), E( * ), E2( * ), GERS( * ), + $ W( * ),WERR( * ), WGAP( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD, + $ MAXGROWTH, ONE, PERT, TWO, ZERO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, + $ TWO = 2.0D0, FOUR=4.0D0, + $ HNDRD = 100.0D0, + $ PERT = 8.0D0, + $ HALF = ONE/TWO, FOURTH = ONE/FOUR, FAC= HALF, + $ MAXGROWTH = 64.0D0, FUDGE = 2.0D0 ) + INTEGER MAXTRY, ALLRNG, INDRNG, VALRNG + PARAMETER ( MAXTRY = 6, ALLRNG = 1, INDRNG = 2, + $ VALRNG = 3 ) +* .. +* .. Local Scalars .. + LOGICAL FORCEB, NOREP, USEDQD + INTEGER CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO, + $ IN, INDL, INDU, IRANGE, J, JBLK, MB, MM, + $ WBEGIN, WEND + DOUBLE PRECISION AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS, + $ EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT, RTL, + $ RTOL, S1, S2, SAFMIN, SGNDEF, SIGMA, SPDIAM, + $ TAU, TMP, TMP1 + + +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME + +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLARNV, DLARRA, DLARRB, DLARRC, DLARRD, + $ DLASQ2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN + +* .. +* .. Executable Statements .. +* + + INFO = 0 + +* +* Decode RANGE +* + IF( LSAME( RANGE, 'A' ) ) THEN + IRANGE = ALLRNG + ELSE IF( LSAME( RANGE, 'V' ) ) THEN + IRANGE = VALRNG + ELSE IF( LSAME( RANGE, 'I' ) ) THEN + IRANGE = INDRNG + END IF + + M = 0 + +* Get machine constants + SAFMIN = DLAMCH( 'S' ) + EPS = DLAMCH( 'P' ) + +* Set parameters + RTL = SQRT(EPS) + BSRTOL = SQRT(EPS) + +* Treat case of 1x1 matrix for quick return + IF( N.EQ.1 ) THEN + IF( (IRANGE.EQ.ALLRNG).OR. + $ ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR. + $ ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN + M = 1 + W(1) = D(1) +* The computation error of the eigenvalue is zero + WERR(1) = ZERO + WGAP(1) = ZERO + IBLOCK( 1 ) = 1 + INDEXW( 1 ) = 1 + GERS(1) = D( 1 ) + GERS(2) = D( 1 ) + ENDIF +* store the shift for the initial RRR, which is zero in this case + E(1) = ZERO + RETURN + END IF + +* General case: tridiagonal matrix of order > 1 +* +* Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter. +* Compute maximum off-diagonal entry and pivmin. + GL = D(1) + GU = D(1) + EOLD = ZERO + EMAX = ZERO + E(N) = ZERO + DO 5 I = 1,N + WERR(I) = ZERO + WGAP(I) = ZERO + EABS = ABS( E(I) ) + IF( EABS .GE. EMAX ) THEN + EMAX = EABS + END IF + TMP1 = EABS + EOLD + GERS( 2*I-1) = D(I) - TMP1 + GL = MIN( GL, GERS( 2*I - 1)) + GERS( 2*I ) = D(I) + TMP1 + GU = MAX( GU, GERS(2*I) ) + EOLD = EABS + 5 CONTINUE +* The minimum pivot allowed in the Sturm sequence for T + PIVMIN = SAFMIN * MAX( ONE, EMAX**2 ) +* Compute spectral diameter. The Gerschgorin bounds give an +* estimate that is wrong by at most a factor of SQRT(2) + SPDIAM = GU - GL + +* Compute splitting points + CALL DLARRA( N, D, E, E2, SPLTOL, SPDIAM, + $ NSPLIT, ISPLIT, IINFO ) + +* Can force use of bisection instead of faster DQDS. +* Option left in the code for future multisection work. + FORCEB = .FALSE. + +* Initialize USEDQD, DQDS should be used for ALLRNG unless someone +* explicitly wants bisection. + USEDQD = (( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB)) + + IF( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ) THEN +* Set interval [VL,VU] that contains all eigenvalues + VL = GL + VU = GU + ELSE +* We call DLARRD to find crude approximations to the eigenvalues +* in the desired range. In case IRANGE = INDRNG, we also obtain the +* interval (VL,VU] that contains all the wanted eigenvalues. +* An interval [LEFT,RIGHT] has converged if +* RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT)) +* DLARRD needs a WORK of size 4*N, IWORK of size 3*N + CALL DLARRD( RANGE, 'B', N, VL, VU, IL, IU, GERS, + $ BSRTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, + $ MM, W, WERR, VL, VU, IBLOCK, INDEXW, + $ WORK, IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = -1 + RETURN + ENDIF +* Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0 + DO 14 I = MM+1,N + W( I ) = ZERO + WERR( I ) = ZERO + IBLOCK( I ) = 0 + INDEXW( I ) = 0 + 14 CONTINUE + END IF + + +*** +* Loop over unreduced blocks + IBEGIN = 1 + WBEGIN = 1 + DO 170 JBLK = 1, NSPLIT + IEND = ISPLIT( JBLK ) + IN = IEND - IBEGIN + 1 + +* 1 X 1 block + IF( IN.EQ.1 ) THEN + IF( (IRANGE.EQ.ALLRNG).OR.( (IRANGE.EQ.VALRNG).AND. + $ ( D( IBEGIN ).GT.VL ).AND.( D( IBEGIN ).LE.VU ) ) + $ .OR. ( (IRANGE.EQ.INDRNG).AND.(IBLOCK(WBEGIN).EQ.JBLK)) + $ ) THEN + M = M + 1 + W( M ) = D( IBEGIN ) + WERR(M) = ZERO +* The gap for a single block doesn't matter for the later +* algorithm and is assigned an arbitrary large value + WGAP(M) = ZERO + IBLOCK( M ) = JBLK + INDEXW( M ) = 1 + WBEGIN = WBEGIN + 1 + ENDIF +* E( IEND ) holds the shift for the initial RRR + E( IEND ) = ZERO + IBEGIN = IEND + 1 + GO TO 170 + END IF +* +* Blocks of size larger than 1x1 +* +* E( IEND ) will hold the shift for the initial RRR, for now set it =0 + E( IEND ) = ZERO +* +* Find local outer bounds GL,GU for the block + GL = D(IBEGIN) + GU = D(IBEGIN) + DO 15 I = IBEGIN , IEND + GL = MIN( GERS( 2*I-1 ), GL ) + GU = MAX( GERS( 2*I ), GU ) + 15 CONTINUE + SPDIAM = GU - GL + + IF(.NOT. ((IRANGE.EQ.ALLRNG).AND.(.NOT.FORCEB)) ) THEN +* Count the number of eigenvalues in the current block. + MB = 0 + DO 20 I = WBEGIN,MM + IF( IBLOCK(I).EQ.JBLK ) THEN + MB = MB+1 + ELSE + GOTO 21 + ENDIF + 20 CONTINUE + 21 CONTINUE + + IF( MB.EQ.0) THEN +* No eigenvalue in the current block lies in the desired range +* E( IEND ) holds the shift for the initial RRR + E( IEND ) = ZERO + IBEGIN = IEND + 1 + GO TO 170 + ELSE + +* Decide whether dqds or bisection is more efficient + USEDQD = ( (MB .GT. FAC*IN) .AND. (.NOT.FORCEB) ) + WEND = WBEGIN + MB - 1 +* Calculate gaps for the current block +* In later stages, when representations for individual +* eigenvalues are different, we use SIGMA = E( IEND ). + SIGMA = ZERO + DO 30 I = WBEGIN, WEND - 1 + WGAP( I ) = MAX( ZERO, + $ W(I+1)-WERR(I+1) - (W(I)+WERR(I)) ) + 30 CONTINUE + WGAP( WEND ) = MAX( ZERO, + $ VU - SIGMA - (W( WEND )+WERR( WEND ))) +* Find local index of the first and last desired evalue. + INDL = INDEXW(WBEGIN) + INDU = INDEXW( WEND ) + ENDIF + ENDIF + IF(( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ).OR.USEDQD) THEN +* Case of DQDS +* Find approximations to the extremal eigenvalues of the block + CALL DLARRK( IN, 1, GL, GU, D(IBEGIN), + $ E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = -1 + RETURN + ENDIF + ISLEFT = MAX(GL, TMP - TMP1 + $ - HNDRD * EPS* ABS(TMP - TMP1)) + + CALL DLARRK( IN, IN, GL, GU, D(IBEGIN), + $ E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = -1 + RETURN + ENDIF + ISRGHT = MIN(GU, TMP + TMP1 + $ + HNDRD * EPS * ABS(TMP + TMP1)) +* Improve the estimate of the spectral diameter + SPDIAM = ISRGHT - ISLEFT + ELSE +* Case of bisection +* Find approximations to the wanted extremal eigenvalues + ISLEFT = MAX(GL, W(WBEGIN) - WERR(WBEGIN) + $ - HNDRD * EPS*ABS(W(WBEGIN)- WERR(WBEGIN) )) + ISRGHT = MIN(GU,W(WEND) + WERR(WEND) + $ + HNDRD * EPS * ABS(W(WEND)+ WERR(WEND))) + ENDIF + + +* Decide whether the base representation for the current block +* L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I +* should be on the left or the right end of the current block. +* The strategy is to shift to the end which is "more populated" +* Furthermore, decide whether to use DQDS for the computation of +* the eigenvalue approximations at the end of DLARRE or bisection. +* dqds is chosen if all eigenvalues are desired or the number of +* eigenvalues to be computed is large compared to the blocksize. + IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN +* If all the eigenvalues have to be computed, we use dqd + USEDQD = .TRUE. +* INDL is the local index of the first eigenvalue to compute + INDL = 1 + INDU = IN +* MB = number of eigenvalues to compute + MB = IN + WEND = WBEGIN + MB - 1 +* Define 1/4 and 3/4 points of the spectrum + S1 = ISLEFT + FOURTH * SPDIAM + S2 = ISRGHT - FOURTH * SPDIAM + ELSE +* DLARRD has computed IBLOCK and INDEXW for each eigenvalue +* approximation. +* choose sigma + IF( USEDQD ) THEN + S1 = ISLEFT + FOURTH * SPDIAM + S2 = ISRGHT - FOURTH * SPDIAM + ELSE + TMP = MIN(ISRGHT,VU) - MAX(ISLEFT,VL) + S1 = MAX(ISLEFT,VL) + FOURTH * TMP + S2 = MIN(ISRGHT,VU) - FOURTH * TMP + ENDIF + ENDIF + +* Compute the negcount at the 1/4 and 3/4 points + IF(MB.GT.1) THEN + CALL DLARRC( 'T', IN, S1, S2, D(IBEGIN), + $ E(IBEGIN), PIVMIN, CNT, CNT1, CNT2, IINFO) + ENDIF + + IF(MB.EQ.1) THEN + SIGMA = GL + SGNDEF = ONE + ELSEIF( CNT1 - INDL .GE. INDU - CNT2 ) THEN + IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN + SIGMA = MAX(ISLEFT,GL) + ELSEIF( USEDQD ) THEN +* use Gerschgorin bound as shift to get pos def matrix +* for dqds + SIGMA = ISLEFT + ELSE +* use approximation of the first desired eigenvalue of the +* block as shift + SIGMA = MAX(ISLEFT,VL) + ENDIF + SGNDEF = ONE + ELSE + IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN + SIGMA = MIN(ISRGHT,GU) + ELSEIF( USEDQD ) THEN +* use Gerschgorin bound as shift to get neg def matrix +* for dqds + SIGMA = ISRGHT + ELSE +* use approximation of the first desired eigenvalue of the +* block as shift + SIGMA = MIN(ISRGHT,VU) + ENDIF + SGNDEF = -ONE + ENDIF + + +* An initial SIGMA has been chosen that will be used for computing +* T - SIGMA I = L D L^T +* Define the increment TAU of the shift in case the initial shift +* needs to be refined to obtain a factorization with not too much +* element growth. + IF( USEDQD ) THEN +* The initial SIGMA was to the outer end of the spectrum +* the matrix is definite and we need not retreat. + TAU = SPDIAM*EPS*N + TWO*PIVMIN + TAU = MAX( TAU,TWO*EPS*ABS(SIGMA) ) + ELSE + IF(MB.GT.1) THEN + CLWDTH = W(WEND) + WERR(WEND) - W(WBEGIN) - WERR(WBEGIN) + AVGAP = ABS(CLWDTH / DBLE(WEND-WBEGIN)) + IF( SGNDEF.EQ.ONE ) THEN + TAU = HALF*MAX(WGAP(WBEGIN),AVGAP) + TAU = MAX(TAU,WERR(WBEGIN)) + ELSE + TAU = HALF*MAX(WGAP(WEND-1),AVGAP) + TAU = MAX(TAU,WERR(WEND)) + ENDIF + ELSE + TAU = WERR(WBEGIN) + ENDIF + ENDIF +* + DO 80 IDUM = 1, MAXTRY +* Compute L D L^T factorization of tridiagonal matrix T - sigma I. +* Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of +* pivots in WORK(2*IN+1:3*IN) + DPIVOT = D( IBEGIN ) - SIGMA + WORK( 1 ) = DPIVOT + DMAX = ABS( WORK(1) ) + J = IBEGIN + DO 70 I = 1, IN - 1 + WORK( 2*IN+I ) = ONE / WORK( I ) + TMP = E( J )*WORK( 2*IN+I ) + WORK( IN+I ) = TMP + DPIVOT = ( D( J+1 )-SIGMA ) - TMP*E( J ) + WORK( I+1 ) = DPIVOT + DMAX = MAX( DMAX, ABS(DPIVOT) ) + J = J + 1 + 70 CONTINUE +* check for element growth + IF( DMAX .GT. MAXGROWTH*SPDIAM ) THEN + NOREP = .TRUE. + ELSE + NOREP = .FALSE. + ENDIF + IF( USEDQD .AND. .NOT.NOREP ) THEN +* Ensure the definiteness of the representation +* All entries of D (of L D L^T) must have the same sign + DO 71 I = 1, IN + TMP = SGNDEF*WORK( I ) + IF( TMP.LT.ZERO ) NOREP = .TRUE. + 71 CONTINUE + ENDIF + IF(NOREP) THEN +* Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin +* shift which makes the matrix definite. So we should end up +* here really only in the case of IRANGE = VALRNG or INDRNG. + IF( IDUM.EQ.MAXTRY-1 ) THEN + IF( SGNDEF.EQ.ONE ) THEN +* The fudged Gerschgorin shift should succeed + SIGMA = + $ GL - FUDGE*SPDIAM*EPS*N - FUDGE*TWO*PIVMIN + ELSE + SIGMA = + $ GU + FUDGE*SPDIAM*EPS*N + FUDGE*TWO*PIVMIN + END IF + ELSE + SIGMA = SIGMA - SGNDEF * TAU + TAU = TWO * TAU + END IF + ELSE +* an initial RRR is found + GO TO 83 + END IF + 80 CONTINUE +* if the program reaches this point, no base representation could be +* found in MAXTRY iterations. + INFO = 2 + RETURN + + 83 CONTINUE +* At this point, we have found an initial base representation +* T - SIGMA I = L D L^T with not too much element growth. +* Store the shift. + E( IEND ) = SIGMA +* Store D and L. + CALL DCOPY( IN, WORK, 1, D( IBEGIN ), 1 ) + CALL DCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 ) + + + IF(MB.GT.1 ) THEN +* +* Perturb each entry of the base representation by a small +* (but random) relative amount to overcome difficulties with +* glued matrices. +* + DO 122 I = 1, 4 + ISEED( I ) = 1 + 122 CONTINUE + + CALL DLARNV(2, ISEED, 2*IN-1, WORK(1)) + DO 125 I = 1,IN-1 + D(IBEGIN+I-1) = D(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(I)) + E(IBEGIN+I-1) = E(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(IN+I)) + 125 CONTINUE + D(IEND) = D(IEND)*(ONE+EPS*FOUR*WORK(IN)) +* + ENDIF +* +* Don't update the Gerschgorin intervals because keeping track +* of the updates would be too much work in DLARRV. +* We update W instead and use it to locate the proper Gerschgorin +* intervals. + +* Compute the required eigenvalues of L D L' by bisection or dqds + IF ( .NOT.USEDQD ) THEN +* If DLARRD has been used, shift the eigenvalue approximations +* according to their representation. This is necessary for +* a uniform DLARRV since dqds computes eigenvalues of the +* shifted representation. In DLARRV, W will always hold the +* UNshifted eigenvalue approximation. + DO 134 J=WBEGIN,WEND + W(J) = W(J) - SIGMA + WERR(J) = WERR(J) + ABS(W(J)) * EPS + 134 CONTINUE +* call DLARRB to reduce eigenvalue error of the approximations +* from DLARRD + DO 135 I = IBEGIN, IEND-1 + WORK( I ) = D( I ) * E( I )**2 + 135 CONTINUE +* use bisection to find EV from INDL to INDU + CALL DLARRB(IN, D(IBEGIN), WORK(IBEGIN), + $ INDL, INDU, RTOL1, RTOL2, INDL-1, + $ W(WBEGIN), WGAP(WBEGIN), WERR(WBEGIN), + $ WORK( 2*N+1 ), IWORK, PIVMIN, SPDIAM, + $ IN, IINFO ) + IF( IINFO .NE. 0 ) THEN + INFO = -4 + RETURN + END IF +* DLARRB computes all gaps correctly except for the last one +* Record distance to VU/GU + WGAP( WEND ) = MAX( ZERO, + $ ( VU-SIGMA ) - ( W( WEND ) + WERR( WEND ) ) ) + DO 138 I = INDL, INDU + M = M + 1 + IBLOCK(M) = JBLK + INDEXW(M) = I + 138 CONTINUE + ELSE +* Call dqds to get all eigs (and then possibly delete unwanted +* eigenvalues). +* Note that dqds finds the eigenvalues of the L D L^T representation +* of T to high relative accuracy. High relative accuracy +* might be lost when the shift of the RRR is subtracted to obtain +* the eigenvalues of T. However, T is not guaranteed to define its +* eigenvalues to high relative accuracy anyway. +* Set RTOL to the order of the tolerance used in DLASQ2 +* This is an ESTIMATED error, the worst case bound is 4*N*EPS +* which is usually too large and requires unnecessary work to be +* done by bisection when computing the eigenvectors + RTOL = LOG(DBLE(IN)) * FOUR * EPS + J = IBEGIN + DO 140 I = 1, IN - 1 + WORK( 2*I-1 ) = ABS( D( J ) ) + WORK( 2*I ) = E( J )*E( J )*WORK( 2*I-1 ) + J = J + 1 + 140 CONTINUE + WORK( 2*IN-1 ) = ABS( D( IEND ) ) + WORK( 2*IN ) = ZERO + CALL DLASQ2( IN, WORK, IINFO ) + IF( IINFO .NE. 0 ) THEN +* If IINFO = -5 then an index is part of a tight cluster +* and should be changed. The index is in IWORK(1) and the +* gap is in WORK(N+1) + INFO = -5 + RETURN + ELSE +* Test that all eigenvalues are positive as expected + DO 149 I = 1, IN + IF( WORK( I ).LT.ZERO ) THEN + INFO = -6 + RETURN + ENDIF + 149 CONTINUE + END IF + IF( SGNDEF.GT.ZERO ) THEN + DO 150 I = INDL, INDU + M = M + 1 + W( M ) = WORK( IN-I+1 ) + IBLOCK( M ) = JBLK + INDEXW( M ) = I + 150 CONTINUE + ELSE + DO 160 I = INDL, INDU + M = M + 1 + W( M ) = -WORK( I ) + IBLOCK( M ) = JBLK + INDEXW( M ) = I + 160 CONTINUE + END IF + + DO 165 I = M - MB + 1, M +* the value of RTOL below should be the tolerance in DLASQ2 + WERR( I ) = RTOL * ABS( W(I) ) + 165 CONTINUE + DO 166 I = M - MB + 1, M - 1 +* compute the right gap between the intervals + WGAP( I ) = MAX( ZERO, + $ W(I+1)-WERR(I+1) - (W(I)+WERR(I)) ) + 166 CONTINUE + WGAP( M ) = MAX( ZERO, + $ ( VU-SIGMA ) - ( W( M ) + WERR( M ) ) ) + END IF +* proceed with next block + IBEGIN = IEND + 1 + WBEGIN = WEND + 1 + 170 CONTINUE +* + + RETURN +* +* end of DLARRE +* + END diff --git a/math/lapack/src/main/fortran/dlarrf.f b/math/lapack/src/main/fortran/dlarrf.f new file mode 100644 index 0000000000..5ad4337ad1 --- /dev/null +++ b/math/lapack/src/main/fortran/dlarrf.f @@ -0,0 +1,488 @@ +*> \brief \b DLARRF finds a new relatively robust representation such that at least one of the eigenvalues is relatively isolated. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARRF( N, D, L, LD, CLSTRT, CLEND, +* W, WGAP, WERR, +* SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, +* DPLUS, LPLUS, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER CLSTRT, CLEND, INFO, N +* DOUBLE PRECISION CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), DPLUS( * ), L( * ), LD( * ), +* $ LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Given the initial representation L D L^T and its cluster of close +*> eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ... +*> W( CLEND ), DLARRF finds a new relatively robust representation +*> L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the +*> eigenvalues of L(+) D(+) L(+)^T is relatively isolated. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix (subblock, if the matrix split). +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The N diagonal elements of the diagonal matrix D. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is DOUBLE PRECISION array, dimension (N-1) +*> The (N-1) subdiagonal elements of the unit bidiagonal +*> matrix L. +*> \endverbatim +*> +*> \param[in] LD +*> \verbatim +*> LD is DOUBLE PRECISION array, dimension (N-1) +*> The (N-1) elements L(i)*D(i). +*> \endverbatim +*> +*> \param[in] CLSTRT +*> \verbatim +*> CLSTRT is INTEGER +*> The index of the first eigenvalue in the cluster. +*> \endverbatim +*> +*> \param[in] CLEND +*> \verbatim +*> CLEND is INTEGER +*> The index of the last eigenvalue in the cluster. +*> \endverbatim +*> +*> \param[in] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension +*> dimension is >= (CLEND-CLSTRT+1) +*> The eigenvalue APPROXIMATIONS of L D L^T in ascending order. +*> W( CLSTRT ) through W( CLEND ) form the cluster of relatively +*> close eigenalues. +*> \endverbatim +*> +*> \param[in,out] WGAP +*> \verbatim +*> WGAP is DOUBLE PRECISION array, dimension +*> dimension is >= (CLEND-CLSTRT+1) +*> The separation from the right neighbor eigenvalue in W. +*> \endverbatim +*> +*> \param[in] WERR +*> \verbatim +*> WERR is DOUBLE PRECISION array, dimension +*> dimension is >= (CLEND-CLSTRT+1) +*> WERR contain the semiwidth of the uncertainty +*> interval of the corresponding eigenvalue APPROXIMATION in W +*> \endverbatim +*> +*> \param[in] SPDIAM +*> \verbatim +*> SPDIAM is DOUBLE PRECISION +*> estimate of the spectral diameter obtained from the +*> Gerschgorin intervals +*> \endverbatim +*> +*> \param[in] CLGAPL +*> \verbatim +*> CLGAPL is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] CLGAPR +*> \verbatim +*> CLGAPR is DOUBLE PRECISION +*> absolute gap on each end of the cluster. +*> Set by the calling routine to protect against shifts too close +*> to eigenvalues outside the cluster. +*> \endverbatim +*> +*> \param[in] PIVMIN +*> \verbatim +*> PIVMIN is DOUBLE PRECISION +*> The minimum pivot allowed in the Sturm sequence. +*> \endverbatim +*> +*> \param[out] SIGMA +*> \verbatim +*> SIGMA is DOUBLE PRECISION +*> The shift used to form L(+) D(+) L(+)^T. +*> \endverbatim +*> +*> \param[out] DPLUS +*> \verbatim +*> DPLUS is DOUBLE PRECISION array, dimension (N) +*> The N diagonal elements of the diagonal matrix D(+). +*> \endverbatim +*> +*> \param[out] LPLUS +*> \verbatim +*> LPLUS is DOUBLE PRECISION array, dimension (N-1) +*> The first (N-1) elements of LPLUS contain the subdiagonal +*> elements of the unit bidiagonal matrix L(+). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> Workspace. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> Signals processing OK (=0) or failure (=1) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Beresford Parlett, University of California, Berkeley, USA \n +*> Jim Demmel, University of California, Berkeley, USA \n +*> Inderjit Dhillon, University of Texas, Austin, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Christof Voemel, University of California, Berkeley, USA +* +* ===================================================================== + SUBROUTINE DLARRF( N, D, L, LD, CLSTRT, CLEND, + $ W, WGAP, WERR, + $ SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, + $ DPLUS, LPLUS, WORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER CLSTRT, CLEND, INFO, N + DOUBLE PRECISION CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), DPLUS( * ), L( * ), LD( * ), + $ LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION FOUR, MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO + PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, FOUR = 4.0D0, + $ QUART = 0.25D0, + $ MAXGROWTH1 = 8.D0, + $ MAXGROWTH2 = 8.D0 ) +* .. +* .. Local Scalars .. + LOGICAL DORRR1, FORCER, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1 + INTEGER I, INDX, KTRY, KTRYMAX, SLEFT, SRIGHT, SHIFT + PARAMETER ( KTRYMAX = 1, SLEFT = 1, SRIGHT = 2 ) + DOUBLE PRECISION AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL, + $ FAIL2, GROWTHBOUND, LDELTA, LDMAX, LSIGMA, + $ MAX1, MAX2, MINGAP, OLDP, PROD, RDELTA, RDMAX, + $ RRR1, RRR2, RSIGMA, S, SMLGROWTH, TMP, ZNM2 +* .. +* .. External Functions .. + LOGICAL DISNAN + DOUBLE PRECISION DLAMCH + EXTERNAL DISNAN, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + INFO = 0 + FACT = DBLE(2**KTRYMAX) + EPS = DLAMCH( 'Precision' ) + SHIFT = 0 + FORCER = .FALSE. + + +* Note that we cannot guarantee that for any of the shifts tried, +* the factorization has a small or even moderate element growth. +* There could be Ritz values at both ends of the cluster and despite +* backing off, there are examples where all factorizations tried +* (in IEEE mode, allowing zero pivots & infinities) have INFINITE +* element growth. +* For this reason, we should use PIVMIN in this subroutine so that at +* least the L D L^T factorization exists. It can be checked afterwards +* whether the element growth caused bad residuals/orthogonality. + +* Decide whether the code should accept the best among all +* representations despite large element growth or signal INFO=1 +* Setting NOFAIL to .FALSE. for quick fix for bug 113 + NOFAIL = .FALSE. +* + +* Compute the average gap length of the cluster + CLWDTH = ABS(W(CLEND)-W(CLSTRT)) + WERR(CLEND) + WERR(CLSTRT) + AVGAP = CLWDTH / DBLE(CLEND-CLSTRT) + MINGAP = MIN(CLGAPL, CLGAPR) +* Initial values for shifts to both ends of cluster + LSIGMA = MIN(W( CLSTRT ),W( CLEND )) - WERR( CLSTRT ) + RSIGMA = MAX(W( CLSTRT ),W( CLEND )) + WERR( CLEND ) + +* Use a small fudge to make sure that we really shift to the outside + LSIGMA = LSIGMA - ABS(LSIGMA)* FOUR * EPS + RSIGMA = RSIGMA + ABS(RSIGMA)* FOUR * EPS + +* Compute upper bounds for how much to back off the initial shifts + LDMAX = QUART * MINGAP + TWO * PIVMIN + RDMAX = QUART * MINGAP + TWO * PIVMIN + + LDELTA = MAX(AVGAP,WGAP( CLSTRT ))/FACT + RDELTA = MAX(AVGAP,WGAP( CLEND-1 ))/FACT +* +* Initialize the record of the best representation found +* + S = DLAMCH( 'S' ) + SMLGROWTH = ONE / S + FAIL = DBLE(N-1)*MINGAP/(SPDIAM*EPS) + FAIL2 = DBLE(N-1)*MINGAP/(SPDIAM*SQRT(EPS)) + BESTSHIFT = LSIGMA +* +* while (KTRY <= KTRYMAX) + KTRY = 0 + GROWTHBOUND = MAXGROWTH1*SPDIAM + + 5 CONTINUE + SAWNAN1 = .FALSE. + SAWNAN2 = .FALSE. +* Ensure that we do not back off too much of the initial shifts + LDELTA = MIN(LDMAX,LDELTA) + RDELTA = MIN(RDMAX,RDELTA) + +* Compute the element growth when shifting to both ends of the cluster +* accept the shift if there is no element growth at one of the two ends + +* Left end + S = -LSIGMA + DPLUS( 1 ) = D( 1 ) + S + IF(ABS(DPLUS(1)).LT.PIVMIN) THEN + DPLUS(1) = -PIVMIN +* Need to set SAWNAN1 because refined RRR test should not be used +* in this case + SAWNAN1 = .TRUE. + ENDIF + MAX1 = ABS( DPLUS( 1 ) ) + DO 6 I = 1, N - 1 + LPLUS( I ) = LD( I ) / DPLUS( I ) + S = S*LPLUS( I )*L( I ) - LSIGMA + DPLUS( I+1 ) = D( I+1 ) + S + IF(ABS(DPLUS(I+1)).LT.PIVMIN) THEN + DPLUS(I+1) = -PIVMIN +* Need to set SAWNAN1 because refined RRR test should not be used +* in this case + SAWNAN1 = .TRUE. + ENDIF + MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) ) + 6 CONTINUE + SAWNAN1 = SAWNAN1 .OR. DISNAN( MAX1 ) + + IF( FORCER .OR. + $ (MAX1.LE.GROWTHBOUND .AND. .NOT.SAWNAN1 ) ) THEN + SIGMA = LSIGMA + SHIFT = SLEFT + GOTO 100 + ENDIF + +* Right end + S = -RSIGMA + WORK( 1 ) = D( 1 ) + S + IF(ABS(WORK(1)).LT.PIVMIN) THEN + WORK(1) = -PIVMIN +* Need to set SAWNAN2 because refined RRR test should not be used +* in this case + SAWNAN2 = .TRUE. + ENDIF + MAX2 = ABS( WORK( 1 ) ) + DO 7 I = 1, N - 1 + WORK( N+I ) = LD( I ) / WORK( I ) + S = S*WORK( N+I )*L( I ) - RSIGMA + WORK( I+1 ) = D( I+1 ) + S + IF(ABS(WORK(I+1)).LT.PIVMIN) THEN + WORK(I+1) = -PIVMIN +* Need to set SAWNAN2 because refined RRR test should not be used +* in this case + SAWNAN2 = .TRUE. + ENDIF + MAX2 = MAX( MAX2,ABS(WORK(I+1)) ) + 7 CONTINUE + SAWNAN2 = SAWNAN2 .OR. DISNAN( MAX2 ) + + IF( FORCER .OR. + $ (MAX2.LE.GROWTHBOUND .AND. .NOT.SAWNAN2 ) ) THEN + SIGMA = RSIGMA + SHIFT = SRIGHT + GOTO 100 + ENDIF +* If we are at this point, both shifts led to too much element growth + +* Record the better of the two shifts (provided it didn't lead to NaN) + IF(SAWNAN1.AND.SAWNAN2) THEN +* both MAX1 and MAX2 are NaN + GOTO 50 + ELSE + IF( .NOT.SAWNAN1 ) THEN + INDX = 1 + IF(MAX1.LE.SMLGROWTH) THEN + SMLGROWTH = MAX1 + BESTSHIFT = LSIGMA + ENDIF + ENDIF + IF( .NOT.SAWNAN2 ) THEN + IF(SAWNAN1 .OR. MAX2.LE.MAX1) INDX = 2 + IF(MAX2.LE.SMLGROWTH) THEN + SMLGROWTH = MAX2 + BESTSHIFT = RSIGMA + ENDIF + ENDIF + ENDIF + +* If we are here, both the left and the right shift led to +* element growth. If the element growth is moderate, then +* we may still accept the representation, if it passes a +* refined test for RRR. This test supposes that no NaN occurred. +* Moreover, we use the refined RRR test only for isolated clusters. + IF((CLWDTH.LT.MINGAP/DBLE(128)) .AND. + $ (MIN(MAX1,MAX2).LT.FAIL2) + $ .AND.(.NOT.SAWNAN1).AND.(.NOT.SAWNAN2)) THEN + DORRR1 = .TRUE. + ELSE + DORRR1 = .FALSE. + ENDIF + TRYRRR1 = .TRUE. + IF( TRYRRR1 .AND. DORRR1 ) THEN + IF(INDX.EQ.1) THEN + TMP = ABS( DPLUS( N ) ) + ZNM2 = ONE + PROD = ONE + OLDP = ONE + DO 15 I = N-1, 1, -1 + IF( PROD .LE. EPS ) THEN + PROD = + $ ((DPLUS(I+1)*WORK(N+I+1))/(DPLUS(I)*WORK(N+I)))*OLDP + ELSE + PROD = PROD*ABS(WORK(N+I)) + END IF + OLDP = PROD + ZNM2 = ZNM2 + PROD**2 + TMP = MAX( TMP, ABS( DPLUS( I ) * PROD )) + 15 CONTINUE + RRR1 = TMP/( SPDIAM * SQRT( ZNM2 ) ) + IF (RRR1.LE.MAXGROWTH2) THEN + SIGMA = LSIGMA + SHIFT = SLEFT + GOTO 100 + ENDIF + ELSE IF(INDX.EQ.2) THEN + TMP = ABS( WORK( N ) ) + ZNM2 = ONE + PROD = ONE + OLDP = ONE + DO 16 I = N-1, 1, -1 + IF( PROD .LE. EPS ) THEN + PROD = ((WORK(I+1)*LPLUS(I+1))/(WORK(I)*LPLUS(I)))*OLDP + ELSE + PROD = PROD*ABS(LPLUS(I)) + END IF + OLDP = PROD + ZNM2 = ZNM2 + PROD**2 + TMP = MAX( TMP, ABS( WORK( I ) * PROD )) + 16 CONTINUE + RRR2 = TMP/( SPDIAM * SQRT( ZNM2 ) ) + IF (RRR2.LE.MAXGROWTH2) THEN + SIGMA = RSIGMA + SHIFT = SRIGHT + GOTO 100 + ENDIF + END IF + ENDIF + + 50 CONTINUE + + IF (KTRY.LT.KTRYMAX) THEN +* If we are here, both shifts failed also the RRR test. +* Back off to the outside + LSIGMA = MAX( LSIGMA - LDELTA, + $ LSIGMA - LDMAX) + RSIGMA = MIN( RSIGMA + RDELTA, + $ RSIGMA + RDMAX ) + LDELTA = TWO * LDELTA + RDELTA = TWO * RDELTA + KTRY = KTRY + 1 + GOTO 5 + ELSE +* None of the representations investigated satisfied our +* criteria. Take the best one we found. + IF((SMLGROWTH.LT.FAIL).OR.NOFAIL) THEN + LSIGMA = BESTSHIFT + RSIGMA = BESTSHIFT + FORCER = .TRUE. + GOTO 5 + ELSE + INFO = 1 + RETURN + ENDIF + END IF + + 100 CONTINUE + IF (SHIFT.EQ.SLEFT) THEN + ELSEIF (SHIFT.EQ.SRIGHT) THEN +* store new L and D back into DPLUS, LPLUS + CALL DCOPY( N, WORK, 1, DPLUS, 1 ) + CALL DCOPY( N-1, WORK(N+1), 1, LPLUS, 1 ) + ENDIF + + RETURN +* +* End of DLARRF +* + END diff --git a/math/lapack/src/main/fortran/dlarrj.f b/math/lapack/src/main/fortran/dlarrj.f new file mode 100644 index 0000000000..ecd136f42b --- /dev/null +++ b/math/lapack/src/main/fortran/dlarrj.f @@ -0,0 +1,373 @@ +*> \brief \b DLARRJ performs refinement of the initial estimates of the eigenvalues of the matrix T. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARRJ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST, +* RTOL, OFFSET, W, WERR, WORK, IWORK, +* PIVMIN, SPDIAM, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IFIRST, ILAST, INFO, N, OFFSET +* DOUBLE PRECISION PIVMIN, RTOL, SPDIAM +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION D( * ), E2( * ), W( * ), +* $ WERR( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Given the initial eigenvalue approximations of T, DLARRJ +*> does bisection to refine the eigenvalues of T, +*> W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial +*> guesses for these eigenvalues are input in W, the corresponding estimate +*> of the error in these guesses in WERR. During bisection, intervals +*> [left, right] are maintained by storing their mid-points and +*> semi-widths in the arrays W and WERR respectively. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The N diagonal elements of T. +*> \endverbatim +*> +*> \param[in] E2 +*> \verbatim +*> E2 is DOUBLE PRECISION array, dimension (N-1) +*> The Squares of the (N-1) subdiagonal elements of T. +*> \endverbatim +*> +*> \param[in] IFIRST +*> \verbatim +*> IFIRST is INTEGER +*> The index of the first eigenvalue to be computed. +*> \endverbatim +*> +*> \param[in] ILAST +*> \verbatim +*> ILAST is INTEGER +*> The index of the last eigenvalue to be computed. +*> \endverbatim +*> +*> \param[in] RTOL +*> \verbatim +*> RTOL is DOUBLE PRECISION +*> Tolerance for the convergence of the bisection intervals. +*> An interval [LEFT,RIGHT] has converged if +*> RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|). +*> \endverbatim +*> +*> \param[in] OFFSET +*> \verbatim +*> OFFSET is INTEGER +*> Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET +*> through ILAST-OFFSET elements of these arrays are to be used. +*> \endverbatim +*> +*> \param[in,out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are +*> estimates of the eigenvalues of L D L^T indexed IFIRST through +*> ILAST. +*> On output, these estimates are refined. +*> \endverbatim +*> +*> \param[in,out] WERR +*> \verbatim +*> WERR is DOUBLE PRECISION array, dimension (N) +*> On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are +*> the errors in the estimates of the corresponding elements in W. +*> On output, these errors are refined. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> Workspace. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*N) +*> Workspace. +*> \endverbatim +*> +*> \param[in] PIVMIN +*> \verbatim +*> PIVMIN is DOUBLE PRECISION +*> The minimum pivot in the Sturm sequence for T. +*> \endverbatim +*> +*> \param[in] SPDIAM +*> \verbatim +*> SPDIAM is DOUBLE PRECISION +*> The spectral diameter of T. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> Error flag. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Beresford Parlett, University of California, Berkeley, USA \n +*> Jim Demmel, University of California, Berkeley, USA \n +*> Inderjit Dhillon, University of Texas, Austin, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Christof Voemel, University of California, Berkeley, USA +* +* ===================================================================== + SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST, + $ RTOL, OFFSET, W, WERR, WORK, IWORK, + $ PIVMIN, SPDIAM, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IFIRST, ILAST, INFO, N, OFFSET + DOUBLE PRECISION PIVMIN, RTOL, SPDIAM +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION D( * ), E2( * ), W( * ), + $ WERR( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, HALF + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ HALF = 0.5D0 ) + INTEGER MAXITR +* .. +* .. Local Scalars .. + INTEGER CNT, I, I1, I2, II, ITER, J, K, NEXT, NINT, + $ OLNINT, P, PREV, SAVI1 + DOUBLE PRECISION DPLUS, FAC, LEFT, MID, RIGHT, S, TMP, WIDTH +* +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + INFO = 0 +* + MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) / + $ LOG( TWO ) ) + 2 +* +* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. +* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while +* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) +* for an unconverged interval is set to the index of the next unconverged +* interval, and is -1 or 0 for a converged interval. Thus a linked +* list of unconverged intervals is set up. +* + + I1 = IFIRST + I2 = ILAST +* The number of unconverged intervals + NINT = 0 +* The last unconverged interval found + PREV = 0 + DO 75 I = I1, I2 + K = 2*I + II = I - OFFSET + LEFT = W( II ) - WERR( II ) + MID = W(II) + RIGHT = W( II ) + WERR( II ) + WIDTH = RIGHT - MID + TMP = MAX( ABS( LEFT ), ABS( RIGHT ) ) + +* The following test prevents the test of converged intervals + IF( WIDTH.LT.RTOL*TMP ) THEN +* This interval has already converged and does not need refinement. +* (Note that the gaps might change through refining the +* eigenvalues, however, they can only get bigger.) +* Remove it from the list. + IWORK( K-1 ) = -1 +* Make sure that I1 always points to the first unconverged interval + IF((I.EQ.I1).AND.(I.LT.I2)) I1 = I + 1 + IF((PREV.GE.I1).AND.(I.LE.I2)) IWORK( 2*PREV-1 ) = I + 1 + ELSE +* unconverged interval found + PREV = I +* Make sure that [LEFT,RIGHT] contains the desired eigenvalue +* +* Do while( CNT(LEFT).GT.I-1 ) +* + FAC = ONE + 20 CONTINUE + CNT = 0 + S = LEFT + DPLUS = D( 1 ) - S + IF( DPLUS.LT.ZERO ) CNT = CNT + 1 + DO 30 J = 2, N + DPLUS = D( J ) - S - E2( J-1 )/DPLUS + IF( DPLUS.LT.ZERO ) CNT = CNT + 1 + 30 CONTINUE + IF( CNT.GT.I-1 ) THEN + LEFT = LEFT - WERR( II )*FAC + FAC = TWO*FAC + GO TO 20 + END IF +* +* Do while( CNT(RIGHT).LT.I ) +* + FAC = ONE + 50 CONTINUE + CNT = 0 + S = RIGHT + DPLUS = D( 1 ) - S + IF( DPLUS.LT.ZERO ) CNT = CNT + 1 + DO 60 J = 2, N + DPLUS = D( J ) - S - E2( J-1 )/DPLUS + IF( DPLUS.LT.ZERO ) CNT = CNT + 1 + 60 CONTINUE + IF( CNT.LT.I ) THEN + RIGHT = RIGHT + WERR( II )*FAC + FAC = TWO*FAC + GO TO 50 + END IF + NINT = NINT + 1 + IWORK( K-1 ) = I + 1 + IWORK( K ) = CNT + END IF + WORK( K-1 ) = LEFT + WORK( K ) = RIGHT + 75 CONTINUE + + + SAVI1 = I1 +* +* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals +* and while (ITER.LT.MAXITR) +* + ITER = 0 + 80 CONTINUE + PREV = I1 - 1 + I = I1 + OLNINT = NINT + + DO 100 P = 1, OLNINT + K = 2*I + II = I - OFFSET + NEXT = IWORK( K-1 ) + LEFT = WORK( K-1 ) + RIGHT = WORK( K ) + MID = HALF*( LEFT + RIGHT ) + +* semiwidth of interval + WIDTH = RIGHT - MID + TMP = MAX( ABS( LEFT ), ABS( RIGHT ) ) + + IF( ( WIDTH.LT.RTOL*TMP ) .OR. + $ (ITER.EQ.MAXITR) )THEN +* reduce number of unconverged intervals + NINT = NINT - 1 +* Mark interval as converged. + IWORK( K-1 ) = 0 + IF( I1.EQ.I ) THEN + I1 = NEXT + ELSE +* Prev holds the last unconverged interval previously examined + IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT + END IF + I = NEXT + GO TO 100 + END IF + PREV = I +* +* Perform one bisection step +* + CNT = 0 + S = MID + DPLUS = D( 1 ) - S + IF( DPLUS.LT.ZERO ) CNT = CNT + 1 + DO 90 J = 2, N + DPLUS = D( J ) - S - E2( J-1 )/DPLUS + IF( DPLUS.LT.ZERO ) CNT = CNT + 1 + 90 CONTINUE + IF( CNT.LE.I-1 ) THEN + WORK( K-1 ) = MID + ELSE + WORK( K ) = MID + END IF + I = NEXT + + 100 CONTINUE + ITER = ITER + 1 +* do another loop if there are still unconverged intervals +* However, in the last iteration, all intervals are accepted +* since this is the best we can do. + IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80 +* +* +* At this point, all the intervals have converged + DO 110 I = SAVI1, ILAST + K = 2*I + II = I - OFFSET +* All intervals marked by '0' have been refined. + IF( IWORK( K-1 ).EQ.0 ) THEN + W( II ) = HALF*( WORK( K-1 )+WORK( K ) ) + WERR( II ) = WORK( K ) - W( II ) + END IF + 110 CONTINUE +* + + RETURN +* +* End of DLARRJ +* + END diff --git a/math/lapack/src/main/fortran/dlarrk.f b/math/lapack/src/main/fortran/dlarrk.f new file mode 100644 index 0000000000..8b307a4933 --- /dev/null +++ b/math/lapack/src/main/fortran/dlarrk.f @@ -0,0 +1,249 @@ +*> \brief \b DLARRK computes one eigenvalue of a symmetric tridiagonal matrix T to suitable accuracy. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARRK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARRK( N, IW, GL, GU, +* D, E2, PIVMIN, RELTOL, W, WERR, INFO) +* +* .. Scalar Arguments .. +* INTEGER INFO, IW, N +* DOUBLE PRECISION PIVMIN, RELTOL, GL, GU, W, WERR +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E2( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARRK computes one eigenvalue of a symmetric tridiagonal +*> matrix T to suitable accuracy. This is an auxiliary code to be +*> called from DSTEMR. +*> +*> To avoid overflow, the matrix must be scaled so that its +*> largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest +*> accuracy, it should not be much smaller than that. +*> +*> See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal +*> Matrix", Report CS41, Computer Science Dept., Stanford +*> University, July 21, 1966. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the tridiagonal matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in] IW +*> \verbatim +*> IW is INTEGER +*> The index of the eigenvalues to be returned. +*> \endverbatim +*> +*> \param[in] GL +*> \verbatim +*> GL is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] GU +*> \verbatim +*> GU is DOUBLE PRECISION +*> An upper and a lower bound on the eigenvalue. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[in] E2 +*> \verbatim +*> E2 is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) squared off-diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[in] PIVMIN +*> \verbatim +*> PIVMIN is DOUBLE PRECISION +*> The minimum pivot allowed in the Sturm sequence for T. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION +*> The minimum relative width of an interval. When an interval +*> is narrower than RELTOL times the larger (in +*> magnitude) endpoint, then it is considered to be +*> sufficiently small, i.e., converged. Note: this should +*> always be at least radix*machine epsilon. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] WERR +*> \verbatim +*> WERR is DOUBLE PRECISION +*> The error bound on the corresponding eigenvalue approximation +*> in W. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Eigenvalue converged +*> = -1: Eigenvalue did NOT converge +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> FUDGE DOUBLE PRECISION, default = 2 +*> A "fudge factor" to widen the Gershgorin intervals. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLARRK( N, IW, GL, GU, + $ D, E2, PIVMIN, RELTOL, W, WERR, INFO) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, IW, N + DOUBLE PRECISION PIVMIN, RELTOL, GL, GU, W, WERR +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E2( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION FUDGE, HALF, TWO, ZERO + PARAMETER ( HALF = 0.5D0, TWO = 2.0D0, + $ FUDGE = TWO, ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I, IT, ITMAX, NEGCNT + DOUBLE PRECISION ATOLI, EPS, LEFT, MID, RIGHT, RTOLI, TMP1, + $ TMP2, TNORM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, INT, LOG, MAX +* .. +* .. Executable Statements .. +* +* Get machine constants + EPS = DLAMCH( 'P' ) + + TNORM = MAX( ABS( GL ), ABS( GU ) ) + RTOLI = RELTOL + ATOLI = FUDGE*TWO*PIVMIN + + ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) / + $ LOG( TWO ) ) + 2 + + INFO = -1 + + LEFT = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN + RIGHT = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN + IT = 0 + + 10 CONTINUE +* +* Check if interval converged or maximum number of iterations reached +* + TMP1 = ABS( RIGHT - LEFT ) + TMP2 = MAX( ABS(RIGHT), ABS(LEFT) ) + IF( TMP1.LT.MAX( ATOLI, PIVMIN, RTOLI*TMP2 ) ) THEN + INFO = 0 + GOTO 30 + ENDIF + IF(IT.GT.ITMAX) + $ GOTO 30 + +* +* Count number of negative pivots for mid-point +* + IT = IT + 1 + MID = HALF * (LEFT + RIGHT) + NEGCNT = 0 + TMP1 = D( 1 ) - MID + IF( ABS( TMP1 ).LT.PIVMIN ) + $ TMP1 = -PIVMIN + IF( TMP1.LE.ZERO ) + $ NEGCNT = NEGCNT + 1 +* + DO 20 I = 2, N + TMP1 = D( I ) - E2( I-1 ) / TMP1 - MID + IF( ABS( TMP1 ).LT.PIVMIN ) + $ TMP1 = -PIVMIN + IF( TMP1.LE.ZERO ) + $ NEGCNT = NEGCNT + 1 + 20 CONTINUE + + IF(NEGCNT.GE.IW) THEN + RIGHT = MID + ELSE + LEFT = MID + ENDIF + GOTO 10 + + 30 CONTINUE +* +* Converged or maximum number of iterations reached +* + W = HALF * (LEFT + RIGHT) + WERR = HALF * ABS( RIGHT - LEFT ) + + RETURN +* +* End of DLARRK +* + END diff --git a/math/lapack/src/main/fortran/dlarrr.f b/math/lapack/src/main/fortran/dlarrr.f new file mode 100644 index 0000000000..c12b605854 --- /dev/null +++ b/math/lapack/src/main/fortran/dlarrr.f @@ -0,0 +1,204 @@ +*> \brief \b DLARRR performs tests to decide whether the symmetric tridiagonal matrix T warrants expensive computations which guarantee high relative accuracy in the eigenvalues. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARRR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARRR( N, D, E, INFO ) +* +* .. Scalar Arguments .. +* INTEGER N, INFO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ) +* .. +* +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Perform tests to decide whether the symmetric tridiagonal matrix T +*> warrants expensive computations which guarantee high relative accuracy +*> in the eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N > 0. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The N diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On entry, the first (N-1) entries contain the subdiagonal +*> elements of the tridiagonal matrix T; E(N) is set to ZERO. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> INFO = 0(default) : the matrix warrants computations preserving +*> relative accuracy. +*> INFO = 1 : the matrix warrants computations guaranteeing +*> only absolute accuracy. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Beresford Parlett, University of California, Berkeley, USA \n +*> Jim Demmel, University of California, Berkeley, USA \n +*> Inderjit Dhillon, University of Texas, Austin, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Christof Voemel, University of California, Berkeley, USA +* +* ===================================================================== + SUBROUTINE DLARRR( N, D, E, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER N, INFO +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) +* .. +* +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, RELCOND + PARAMETER ( ZERO = 0.0D0, + $ RELCOND = 0.999D0 ) +* .. +* .. Local Scalars .. + INTEGER I + LOGICAL YESREL + DOUBLE PRECISION EPS, SAFMIN, SMLNUM, RMIN, TMP, TMP2, + $ OFFDIG, OFFDIG2 + +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* +* As a default, do NOT go for relative-accuracy preserving computations. + INFO = 1 + + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + RMIN = SQRT( SMLNUM ) + +* Tests for relative accuracy +* +* Test for scaled diagonal dominance +* Scale the diagonal entries to one and check whether the sum of the +* off-diagonals is less than one +* +* The sdd relative error bounds have a 1/(1- 2*x) factor in them, +* x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative +* accuracy is promised. In the notation of the code fragment below, +* 1/(1 - (OFFDIG + OFFDIG2)) is the condition number. +* We don't think it is worth going into "sdd mode" unless the relative +* condition number is reasonable, not 1/macheps. +* The threshold should be compatible with other thresholds used in the +* code. We set OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds +* to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000 +* instead of the current OFFDIG + OFFDIG2 < 1 +* + YESREL = .TRUE. + OFFDIG = ZERO + TMP = SQRT(ABS(D(1))) + IF (TMP.LT.RMIN) YESREL = .FALSE. + IF(.NOT.YESREL) GOTO 11 + DO 10 I = 2, N + TMP2 = SQRT(ABS(D(I))) + IF (TMP2.LT.RMIN) YESREL = .FALSE. + IF(.NOT.YESREL) GOTO 11 + OFFDIG2 = ABS(E(I-1))/(TMP*TMP2) + IF(OFFDIG+OFFDIG2.GE.RELCOND) YESREL = .FALSE. + IF(.NOT.YESREL) GOTO 11 + TMP = TMP2 + OFFDIG = OFFDIG2 + 10 CONTINUE + 11 CONTINUE + + IF( YESREL ) THEN + INFO = 0 + RETURN + ELSE + ENDIF +* + +* +* *** MORE TO BE IMPLEMENTED *** +* + +* +* Test if the lower bidiagonal matrix L from T = L D L^T +* (zero shift facto) is well conditioned +* + +* +* Test if the upper bidiagonal matrix U from T = U D U^T +* (zero shift facto) is well conditioned. +* In this case, the matrix needs to be flipped and, at the end +* of the eigenvector computation, the flip needs to be applied +* to the computed eigenvectors (and the support) +* + +* + RETURN +* +* END OF DLARRR +* + END diff --git a/math/lapack/src/main/fortran/dlarrv.f b/math/lapack/src/main/fortran/dlarrv.f new file mode 100644 index 0000000000..edda67d7db --- /dev/null +++ b/math/lapack/src/main/fortran/dlarrv.f @@ -0,0 +1,1032 @@ +*> \brief \b DLARRV computes the eigenvectors of the tridiagonal matrix T = L D LT given L, D and the eigenvalues of L D LT. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARRV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARRV( N, VL, VU, D, L, PIVMIN, +* ISPLIT, M, DOL, DOU, MINRGP, +* RTOL1, RTOL2, W, WERR, WGAP, +* IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER DOL, DOU, INFO, LDZ, M, N +* DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ), +* $ ISUPPZ( * ), IWORK( * ) +* DOUBLE PRECISION D( * ), GERS( * ), L( * ), W( * ), WERR( * ), +* $ WGAP( * ), WORK( * ) +* DOUBLE PRECISION Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARRV computes the eigenvectors of the tridiagonal matrix +*> T = L D L**T given L, D and APPROXIMATIONS to the eigenvalues of L D L**T. +*> The input eigenvalues should have been computed by DLARRE. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> Lower bound of the interval that contains the desired +*> eigenvalues. VL < VU. Needed to compute gaps on the left or right +*> end of the extremal eigenvalues in the desired RANGE. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> Upper bound of the interval that contains the desired +*> eigenvalues. VL < VU. Needed to compute gaps on the left or right +*> end of the extremal eigenvalues in the desired RANGE. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the N diagonal elements of the diagonal matrix D. +*> On exit, D may be overwritten. +*> \endverbatim +*> +*> \param[in,out] L +*> \verbatim +*> L is DOUBLE PRECISION array, dimension (N) +*> On entry, the (N-1) subdiagonal elements of the unit +*> bidiagonal matrix L are in elements 1 to N-1 of L +*> (if the matrix is not split.) At the end of each block +*> is stored the corresponding shift as given by DLARRE. +*> On exit, L is overwritten. +*> \endverbatim +*> +*> \param[in] PIVMIN +*> \verbatim +*> PIVMIN is DOUBLE PRECISION +*> The minimum pivot allowed in the Sturm sequence. +*> \endverbatim +*> +*> \param[in] ISPLIT +*> \verbatim +*> ISPLIT is INTEGER array, dimension (N) +*> The splitting points, at which T breaks up into blocks. +*> The first block consists of rows/columns 1 to +*> ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 +*> through ISPLIT( 2 ), etc. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The total number of input eigenvalues. 0 <= M <= N. +*> \endverbatim +*> +*> \param[in] DOL +*> \verbatim +*> DOL is INTEGER +*> \endverbatim +*> +*> \param[in] DOU +*> \verbatim +*> DOU is INTEGER +*> If the user wants to compute only selected eigenvectors from all +*> the eigenvalues supplied, he can specify an index range DOL:DOU. +*> Or else the setting DOL=1, DOU=M should be applied. +*> Note that DOL and DOU refer to the order in which the eigenvalues +*> are stored in W. +*> If the user wants to compute only selected eigenpairs, then +*> the columns DOL-1 to DOU+1 of the eigenvector space Z contain the +*> computed eigenvectors. All other columns of Z are set to zero. +*> \endverbatim +*> +*> \param[in] MINRGP +*> \verbatim +*> MINRGP is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] RTOL1 +*> \verbatim +*> RTOL1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] RTOL2 +*> \verbatim +*> RTOL2 is DOUBLE PRECISION +*> Parameters for bisection. +*> An interval [LEFT,RIGHT] has converged if +*> RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) +*> \endverbatim +*> +*> \param[in,out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first M elements of W contain the APPROXIMATE eigenvalues for +*> which eigenvectors are to be computed. The eigenvalues +*> should be grouped by split-off block and ordered from +*> smallest to largest within the block ( The output array +*> W from DLARRE is expected here ). Furthermore, they are with +*> respect to the shift of the corresponding root representation +*> for their block. On exit, W holds the eigenvalues of the +*> UNshifted matrix. +*> \endverbatim +*> +*> \param[in,out] WERR +*> \verbatim +*> WERR is DOUBLE PRECISION array, dimension (N) +*> The first M elements contain the semiwidth of the uncertainty +*> interval of the corresponding eigenvalue in W +*> \endverbatim +*> +*> \param[in,out] WGAP +*> \verbatim +*> WGAP is DOUBLE PRECISION array, dimension (N) +*> The separation from the right neighbor eigenvalue in W. +*> \endverbatim +*> +*> \param[in] IBLOCK +*> \verbatim +*> IBLOCK is INTEGER array, dimension (N) +*> The indices of the blocks (submatrices) associated with the +*> corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue +*> W(i) belongs to the first block from the top, =2 if W(i) +*> belongs to the second block, etc. +*> \endverbatim +*> +*> \param[in] INDEXW +*> \verbatim +*> INDEXW is INTEGER array, dimension (N) +*> The indices of the eigenvalues within each block (submatrix); +*> for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the +*> i-th eigenvalue W(i) is the 10-th eigenvalue in the second block. +*> \endverbatim +*> +*> \param[in] GERS +*> \verbatim +*> GERS is DOUBLE PRECISION array, dimension (2*N) +*> The N Gerschgorin intervals (the i-th Gerschgorin interval +*> is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should +*> be computed from the original UNshifted matrix. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) +*> If INFO = 0, the first M columns of Z contain the +*> orthonormal eigenvectors of the matrix T +*> corresponding to the input eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] ISUPPZ +*> \verbatim +*> ISUPPZ is INTEGER array, dimension ( 2*max(1,M) ) +*> The support of the eigenvectors in Z, i.e., the indices +*> indicating the nonzero elements in Z. The I-th eigenvector +*> is nonzero only in elements ISUPPZ( 2*I-1 ) through +*> ISUPPZ( 2*I ). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (12*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (7*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> > 0: A problem occurred in DLARRV. +*> < 0: One of the called subroutines signaled an internal problem. +*> Needs inspection of the corresponding parameter IINFO +*> for further information. +*> +*> =-1: Problem in DLARRB when refining a child's eigenvalues. +*> =-2: Problem in DLARRF when computing the RRR of a child. +*> When a child is inside a tight cluster, it can be difficult +*> to find an RRR. A partial remedy from the user's point of +*> view is to make the parameter MINRGP smaller and recompile. +*> However, as the orthogonality of the computed vectors is +*> proportional to 1/MINRGP, the user should be aware that +*> he might be trading in precision when he decreases MINRGP. +*> =-3: Problem in DLARRB when refining a single eigenvalue +*> after the Rayleigh correction was rejected. +*> = 5: The Rayleigh Quotient Iteration failed to converge to +*> full accuracy in MAXITR steps. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Beresford Parlett, University of California, Berkeley, USA \n +*> Jim Demmel, University of California, Berkeley, USA \n +*> Inderjit Dhillon, University of Texas, Austin, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Christof Voemel, University of California, Berkeley, USA +* +* ===================================================================== + SUBROUTINE DLARRV( N, VL, VU, D, L, PIVMIN, + $ ISPLIT, M, DOL, DOU, MINRGP, + $ RTOL1, RTOL2, W, WERR, WGAP, + $ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, + $ WORK, IWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER DOL, DOU, INFO, LDZ, M, N + DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU +* .. +* .. Array Arguments .. + INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ), + $ ISUPPZ( * ), IWORK( * ) + DOUBLE PRECISION D( * ), GERS( * ), L( * ), W( * ), WERR( * ), + $ WGAP( * ), WORK( * ) + DOUBLE PRECISION Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER MAXITR + PARAMETER ( MAXITR = 10 ) + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, HALF + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, + $ TWO = 2.0D0, THREE = 3.0D0, + $ FOUR = 4.0D0, HALF = 0.5D0) +* .. +* .. Local Scalars .. + LOGICAL ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ + INTEGER DONE, I, IBEGIN, IDONE, IEND, II, IINDC1, + $ IINDC2, IINDR, IINDWK, IINFO, IM, IN, INDEIG, + $ INDLD, INDLLD, INDWRK, ISUPMN, ISUPMX, ITER, + $ ITMP1, J, JBLK, K, MINIWSIZE, MINWSIZE, NCLUS, + $ NDEPTH, NEGCNT, NEWCLS, NEWFST, NEWFTT, NEWLST, + $ NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN, OLDLST, + $ OLDNCL, P, PARITY, Q, WBEGIN, WEND, WINDEX, + $ WINDMN, WINDPL, ZFROM, ZTO, ZUSEDL, ZUSEDU, + $ ZUSEDW + DOUBLE PRECISION BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU, + $ LAMBDA, LEFT, LGAP, MINGMA, NRMINV, RESID, + $ RGAP, RIGHT, RQCORR, RQTOL, SAVGAP, SGNDEF, + $ SIGMA, SPDIAM, SSIGMA, TAU, TMP, TOL, ZTZ +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLAR1V, DLARRB, DLARRF, DLASET, + $ DSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* .. + + INFO = 0 +* The first N entries of WORK are reserved for the eigenvalues + INDLD = N+1 + INDLLD= 2*N+1 + INDWRK= 3*N+1 + MINWSIZE = 12 * N + + DO 5 I= 1,MINWSIZE + WORK( I ) = ZERO + 5 CONTINUE + +* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the +* factorization used to compute the FP vector + IINDR = 0 +* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current +* layer and the one above. + IINDC1 = N + IINDC2 = 2*N + IINDWK = 3*N + 1 + + MINIWSIZE = 7 * N + DO 10 I= 1,MINIWSIZE + IWORK( I ) = 0 + 10 CONTINUE + + ZUSEDL = 1 + IF(DOL.GT.1) THEN +* Set lower bound for use of Z + ZUSEDL = DOL-1 + ENDIF + ZUSEDU = M + IF(DOU.LT.M) THEN +* Set lower bound for use of Z + ZUSEDU = DOU+1 + ENDIF +* The width of the part of Z that is used + ZUSEDW = ZUSEDU - ZUSEDL + 1 + + + CALL DLASET( 'Full', N, ZUSEDW, ZERO, ZERO, + $ Z(1,ZUSEDL), LDZ ) + + EPS = DLAMCH( 'Precision' ) + RQTOL = TWO * EPS +* +* Set expert flags for standard code. + TRYRQC = .TRUE. + + IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN + ELSE +* Only selected eigenpairs are computed. Since the other evalues +* are not refined by RQ iteration, bisection has to compute to full +* accuracy. + RTOL1 = FOUR * EPS + RTOL2 = FOUR * EPS + ENDIF + +* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the +* desired eigenvalues. The support of the nonzero eigenvector +* entries is contained in the interval IBEGIN:IEND. +* Remark that if k eigenpairs are desired, then the eigenvectors +* are stored in k contiguous columns of Z. + +* DONE is the number of eigenvectors already computed + DONE = 0 + IBEGIN = 1 + WBEGIN = 1 + DO 170 JBLK = 1, IBLOCK( M ) + IEND = ISPLIT( JBLK ) + SIGMA = L( IEND ) +* Find the eigenvectors of the submatrix indexed IBEGIN +* through IEND. + WEND = WBEGIN - 1 + 15 CONTINUE + IF( WEND.LT.M ) THEN + IF( IBLOCK( WEND+1 ).EQ.JBLK ) THEN + WEND = WEND + 1 + GO TO 15 + END IF + END IF + IF( WEND.LT.WBEGIN ) THEN + IBEGIN = IEND + 1 + GO TO 170 + ELSEIF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN + IBEGIN = IEND + 1 + WBEGIN = WEND + 1 + GO TO 170 + END IF + +* Find local spectral diameter of the block + GL = GERS( 2*IBEGIN-1 ) + GU = GERS( 2*IBEGIN ) + DO 20 I = IBEGIN+1 , IEND + GL = MIN( GERS( 2*I-1 ), GL ) + GU = MAX( GERS( 2*I ), GU ) + 20 CONTINUE + SPDIAM = GU - GL + +* OLDIEN is the last index of the previous block + OLDIEN = IBEGIN - 1 +* Calculate the size of the current block + IN = IEND - IBEGIN + 1 +* The number of eigenvalues in the current block + IM = WEND - WBEGIN + 1 + +* This is for a 1x1 block + IF( IBEGIN.EQ.IEND ) THEN + DONE = DONE+1 + Z( IBEGIN, WBEGIN ) = ONE + ISUPPZ( 2*WBEGIN-1 ) = IBEGIN + ISUPPZ( 2*WBEGIN ) = IBEGIN + W( WBEGIN ) = W( WBEGIN ) + SIGMA + WORK( WBEGIN ) = W( WBEGIN ) + IBEGIN = IEND + 1 + WBEGIN = WBEGIN + 1 + GO TO 170 + END IF + +* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND) +* Note that these can be approximations, in this case, the corresp. +* entries of WERR give the size of the uncertainty interval. +* The eigenvalue approximations will be refined when necessary as +* high relative accuracy is required for the computation of the +* corresponding eigenvectors. + CALL DCOPY( IM, W( WBEGIN ), 1, + $ WORK( WBEGIN ), 1 ) + +* We store in W the eigenvalue approximations w.r.t. the original +* matrix T. + DO 30 I=1,IM + W(WBEGIN+I-1) = W(WBEGIN+I-1)+SIGMA + 30 CONTINUE + + +* NDEPTH is the current depth of the representation tree + NDEPTH = 0 +* PARITY is either 1 or 0 + PARITY = 1 +* NCLUS is the number of clusters for the next level of the +* representation tree, we start with NCLUS = 1 for the root + NCLUS = 1 + IWORK( IINDC1+1 ) = 1 + IWORK( IINDC1+2 ) = IM + +* IDONE is the number of eigenvectors already computed in the current +* block + IDONE = 0 +* loop while( IDONE.LT.IM ) +* generate the representation tree for the current block and +* compute the eigenvectors + 40 CONTINUE + IF( IDONE.LT.IM ) THEN +* This is a crude protection against infinitely deep trees + IF( NDEPTH.GT.M ) THEN + INFO = -2 + RETURN + ENDIF +* breadth first processing of the current level of the representation +* tree: OLDNCL = number of clusters on current level + OLDNCL = NCLUS +* reset NCLUS to count the number of child clusters + NCLUS = 0 +* + PARITY = 1 - PARITY + IF( PARITY.EQ.0 ) THEN + OLDCLS = IINDC1 + NEWCLS = IINDC2 + ELSE + OLDCLS = IINDC2 + NEWCLS = IINDC1 + END IF +* Process the clusters on the current level + DO 150 I = 1, OLDNCL + J = OLDCLS + 2*I +* OLDFST, OLDLST = first, last index of current cluster. +* cluster indices start with 1 and are relative +* to WBEGIN when accessing W, WGAP, WERR, Z + OLDFST = IWORK( J-1 ) + OLDLST = IWORK( J ) + IF( NDEPTH.GT.0 ) THEN +* Retrieve relatively robust representation (RRR) of cluster +* that has been computed at the previous level +* The RRR is stored in Z and overwritten once the eigenvectors +* have been computed or when the cluster is refined + + IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN +* Get representation from location of the leftmost evalue +* of the cluster + J = WBEGIN + OLDFST - 1 + ELSE + IF(WBEGIN+OLDFST-1.LT.DOL) THEN +* Get representation from the left end of Z array + J = DOL - 1 + ELSEIF(WBEGIN+OLDFST-1.GT.DOU) THEN +* Get representation from the right end of Z array + J = DOU + ELSE + J = WBEGIN + OLDFST - 1 + ENDIF + ENDIF + CALL DCOPY( IN, Z( IBEGIN, J ), 1, D( IBEGIN ), 1 ) + CALL DCOPY( IN-1, Z( IBEGIN, J+1 ), 1, L( IBEGIN ), + $ 1 ) + SIGMA = Z( IEND, J+1 ) + +* Set the corresponding entries in Z to zero + CALL DLASET( 'Full', IN, 2, ZERO, ZERO, + $ Z( IBEGIN, J), LDZ ) + END IF + +* Compute DL and DLL of current RRR + DO 50 J = IBEGIN, IEND-1 + TMP = D( J )*L( J ) + WORK( INDLD-1+J ) = TMP + WORK( INDLLD-1+J ) = TMP*L( J ) + 50 CONTINUE + + IF( NDEPTH.GT.0 ) THEN +* P and Q are index of the first and last eigenvalue to compute +* within the current block + P = INDEXW( WBEGIN-1+OLDFST ) + Q = INDEXW( WBEGIN-1+OLDLST ) +* Offset for the arrays WORK, WGAP and WERR, i.e., the P-OFFSET +* through the Q-OFFSET elements of these arrays are to be used. +* OFFSET = P-OLDFST + OFFSET = INDEXW( WBEGIN ) - 1 +* perform limited bisection (if necessary) to get approximate +* eigenvalues to the precision needed. + CALL DLARRB( IN, D( IBEGIN ), + $ WORK(INDLLD+IBEGIN-1), + $ P, Q, RTOL1, RTOL2, OFFSET, + $ WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN), + $ WORK( INDWRK ), IWORK( IINDWK ), + $ PIVMIN, SPDIAM, IN, IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = -1 + RETURN + ENDIF +* We also recompute the extremal gaps. W holds all eigenvalues +* of the unshifted matrix and must be used for computation +* of WGAP, the entries of WORK might stem from RRRs with +* different shifts. The gaps from WBEGIN-1+OLDFST to +* WBEGIN-1+OLDLST are correctly computed in DLARRB. +* However, we only allow the gaps to become greater since +* this is what should happen when we decrease WERR + IF( OLDFST.GT.1) THEN + WGAP( WBEGIN+OLDFST-2 ) = + $ MAX(WGAP(WBEGIN+OLDFST-2), + $ W(WBEGIN+OLDFST-1)-WERR(WBEGIN+OLDFST-1) + $ - W(WBEGIN+OLDFST-2)-WERR(WBEGIN+OLDFST-2) ) + ENDIF + IF( WBEGIN + OLDLST -1 .LT. WEND ) THEN + WGAP( WBEGIN+OLDLST-1 ) = + $ MAX(WGAP(WBEGIN+OLDLST-1), + $ W(WBEGIN+OLDLST)-WERR(WBEGIN+OLDLST) + $ - W(WBEGIN+OLDLST-1)-WERR(WBEGIN+OLDLST-1) ) + ENDIF +* Each time the eigenvalues in WORK get refined, we store +* the newly found approximation with all shifts applied in W + DO 53 J=OLDFST,OLDLST + W(WBEGIN+J-1) = WORK(WBEGIN+J-1)+SIGMA + 53 CONTINUE + END IF + +* Process the current node. + NEWFST = OLDFST + DO 140 J = OLDFST, OLDLST + IF( J.EQ.OLDLST ) THEN +* we are at the right end of the cluster, this is also the +* boundary of the child cluster + NEWLST = J + ELSE IF ( WGAP( WBEGIN + J -1).GE. + $ MINRGP* ABS( WORK(WBEGIN + J -1) ) ) THEN +* the right relative gap is big enough, the child cluster +* (NEWFST,..,NEWLST) is well separated from the following + NEWLST = J + ELSE +* inside a child cluster, the relative gap is not +* big enough. + GOTO 140 + END IF + +* Compute size of child cluster found + NEWSIZ = NEWLST - NEWFST + 1 + +* NEWFTT is the place in Z where the new RRR or the computed +* eigenvector is to be stored + IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN +* Store representation at location of the leftmost evalue +* of the cluster + NEWFTT = WBEGIN + NEWFST - 1 + ELSE + IF(WBEGIN+NEWFST-1.LT.DOL) THEN +* Store representation at the left end of Z array + NEWFTT = DOL - 1 + ELSEIF(WBEGIN+NEWFST-1.GT.DOU) THEN +* Store representation at the right end of Z array + NEWFTT = DOU + ELSE + NEWFTT = WBEGIN + NEWFST - 1 + ENDIF + ENDIF + + IF( NEWSIZ.GT.1) THEN +* +* Current child is not a singleton but a cluster. +* Compute and store new representation of child. +* +* +* Compute left and right cluster gap. +* +* LGAP and RGAP are not computed from WORK because +* the eigenvalue approximations may stem from RRRs +* different shifts. However, W hold all eigenvalues +* of the unshifted matrix. Still, the entries in WGAP +* have to be computed from WORK since the entries +* in W might be of the same order so that gaps are not +* exhibited correctly for very close eigenvalues. + IF( NEWFST.EQ.1 ) THEN + LGAP = MAX( ZERO, + $ W(WBEGIN)-WERR(WBEGIN) - VL ) + ELSE + LGAP = WGAP( WBEGIN+NEWFST-2 ) + ENDIF + RGAP = WGAP( WBEGIN+NEWLST-1 ) +* +* Compute left- and rightmost eigenvalue of child +* to high precision in order to shift as close +* as possible and obtain as large relative gaps +* as possible +* + DO 55 K =1,2 + IF(K.EQ.1) THEN + P = INDEXW( WBEGIN-1+NEWFST ) + ELSE + P = INDEXW( WBEGIN-1+NEWLST ) + ENDIF + OFFSET = INDEXW( WBEGIN ) - 1 + CALL DLARRB( IN, D(IBEGIN), + $ WORK( INDLLD+IBEGIN-1 ),P,P, + $ RQTOL, RQTOL, OFFSET, + $ WORK(WBEGIN),WGAP(WBEGIN), + $ WERR(WBEGIN),WORK( INDWRK ), + $ IWORK( IINDWK ), PIVMIN, SPDIAM, + $ IN, IINFO ) + 55 CONTINUE +* + IF((WBEGIN+NEWLST-1.LT.DOL).OR. + $ (WBEGIN+NEWFST-1.GT.DOU)) THEN +* if the cluster contains no desired eigenvalues +* skip the computation of that branch of the rep. tree +* +* We could skip before the refinement of the extremal +* eigenvalues of the child, but then the representation +* tree could be different from the one when nothing is +* skipped. For this reason we skip at this place. + IDONE = IDONE + NEWLST - NEWFST + 1 + GOTO 139 + ENDIF +* +* Compute RRR of child cluster. +* Note that the new RRR is stored in Z +* +* DLARRF needs LWORK = 2*N + CALL DLARRF( IN, D( IBEGIN ), L( IBEGIN ), + $ WORK(INDLD+IBEGIN-1), + $ NEWFST, NEWLST, WORK(WBEGIN), + $ WGAP(WBEGIN), WERR(WBEGIN), + $ SPDIAM, LGAP, RGAP, PIVMIN, TAU, + $ Z(IBEGIN, NEWFTT),Z(IBEGIN, NEWFTT+1), + $ WORK( INDWRK ), IINFO ) + IF( IINFO.EQ.0 ) THEN +* a new RRR for the cluster was found by DLARRF +* update shift and store it + SSIGMA = SIGMA + TAU + Z( IEND, NEWFTT+1 ) = SSIGMA +* WORK() are the midpoints and WERR() the semi-width +* Note that the entries in W are unchanged. + DO 116 K = NEWFST, NEWLST + FUDGE = + $ THREE*EPS*ABS(WORK(WBEGIN+K-1)) + WORK( WBEGIN + K - 1 ) = + $ WORK( WBEGIN + K - 1) - TAU + FUDGE = FUDGE + + $ FOUR*EPS*ABS(WORK(WBEGIN+K-1)) +* Fudge errors + WERR( WBEGIN + K - 1 ) = + $ WERR( WBEGIN + K - 1 ) + FUDGE +* Gaps are not fudged. Provided that WERR is small +* when eigenvalues are close, a zero gap indicates +* that a new representation is needed for resolving +* the cluster. A fudge could lead to a wrong decision +* of judging eigenvalues 'separated' which in +* reality are not. This could have a negative impact +* on the orthogonality of the computed eigenvectors. + 116 CONTINUE + + NCLUS = NCLUS + 1 + K = NEWCLS + 2*NCLUS + IWORK( K-1 ) = NEWFST + IWORK( K ) = NEWLST + ELSE + INFO = -2 + RETURN + ENDIF + ELSE +* +* Compute eigenvector of singleton +* + ITER = 0 +* + TOL = FOUR * LOG(DBLE(IN)) * EPS +* + K = NEWFST + WINDEX = WBEGIN + K - 1 + WINDMN = MAX(WINDEX - 1,1) + WINDPL = MIN(WINDEX + 1,M) + LAMBDA = WORK( WINDEX ) + DONE = DONE + 1 +* Check if eigenvector computation is to be skipped + IF((WINDEX.LT.DOL).OR. + $ (WINDEX.GT.DOU)) THEN + ESKIP = .TRUE. + GOTO 125 + ELSE + ESKIP = .FALSE. + ENDIF + LEFT = WORK( WINDEX ) - WERR( WINDEX ) + RIGHT = WORK( WINDEX ) + WERR( WINDEX ) + INDEIG = INDEXW( WINDEX ) +* Note that since we compute the eigenpairs for a child, +* all eigenvalue approximations are w.r.t the same shift. +* In this case, the entries in WORK should be used for +* computing the gaps since they exhibit even very small +* differences in the eigenvalues, as opposed to the +* entries in W which might "look" the same. + + IF( K .EQ. 1) THEN +* In the case RANGE='I' and with not much initial +* accuracy in LAMBDA and VL, the formula +* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA ) +* can lead to an overestimation of the left gap and +* thus to inadequately early RQI 'convergence'. +* Prevent this by forcing a small left gap. + LGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT)) + ELSE + LGAP = WGAP(WINDMN) + ENDIF + IF( K .EQ. IM) THEN +* In the case RANGE='I' and with not much initial +* accuracy in LAMBDA and VU, the formula +* can lead to an overestimation of the right gap and +* thus to inadequately early RQI 'convergence'. +* Prevent this by forcing a small right gap. + RGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT)) + ELSE + RGAP = WGAP(WINDEX) + ENDIF + GAP = MIN( LGAP, RGAP ) + IF(( K .EQ. 1).OR.(K .EQ. IM)) THEN +* The eigenvector support can become wrong +* because significant entries could be cut off due to a +* large GAPTOL parameter in LAR1V. Prevent this. + GAPTOL = ZERO + ELSE + GAPTOL = GAP * EPS + ENDIF + ISUPMN = IN + ISUPMX = 1 +* Update WGAP so that it holds the minimum gap +* to the left or the right. This is crucial in the +* case where bisection is used to ensure that the +* eigenvalue is refined up to the required precision. +* The correct value is restored afterwards. + SAVGAP = WGAP(WINDEX) + WGAP(WINDEX) = GAP +* We want to use the Rayleigh Quotient Correction +* as often as possible since it converges quadratically +* when we are close enough to the desired eigenvalue. +* However, the Rayleigh Quotient can have the wrong sign +* and lead us away from the desired eigenvalue. In this +* case, the best we can do is to use bisection. + USEDBS = .FALSE. + USEDRQ = .FALSE. +* Bisection is initially turned off unless it is forced + NEEDBS = .NOT.TRYRQC + 120 CONTINUE +* Check if bisection should be used to refine eigenvalue + IF(NEEDBS) THEN +* Take the bisection as new iterate + USEDBS = .TRUE. + ITMP1 = IWORK( IINDR+WINDEX ) + OFFSET = INDEXW( WBEGIN ) - 1 + CALL DLARRB( IN, D(IBEGIN), + $ WORK(INDLLD+IBEGIN-1),INDEIG,INDEIG, + $ ZERO, TWO*EPS, OFFSET, + $ WORK(WBEGIN),WGAP(WBEGIN), + $ WERR(WBEGIN),WORK( INDWRK ), + $ IWORK( IINDWK ), PIVMIN, SPDIAM, + $ ITMP1, IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = -3 + RETURN + ENDIF + LAMBDA = WORK( WINDEX ) +* Reset twist index from inaccurate LAMBDA to +* force computation of true MINGMA + IWORK( IINDR+WINDEX ) = 0 + ENDIF +* Given LAMBDA, compute the eigenvector. + CALL DLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ), + $ L( IBEGIN ), WORK(INDLD+IBEGIN-1), + $ WORK(INDLLD+IBEGIN-1), + $ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ), + $ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA, + $ IWORK( IINDR+WINDEX ), ISUPPZ( 2*WINDEX-1 ), + $ NRMINV, RESID, RQCORR, WORK( INDWRK ) ) + IF(ITER .EQ. 0) THEN + BSTRES = RESID + BSTW = LAMBDA + ELSEIF(RESID.LT.BSTRES) THEN + BSTRES = RESID + BSTW = LAMBDA + ENDIF + ISUPMN = MIN(ISUPMN,ISUPPZ( 2*WINDEX-1 )) + ISUPMX = MAX(ISUPMX,ISUPPZ( 2*WINDEX )) + ITER = ITER + 1 + +* sin alpha <= |resid|/gap +* Note that both the residual and the gap are +* proportional to the matrix, so ||T|| doesn't play +* a role in the quotient + +* +* Convergence test for Rayleigh-Quotient iteration +* (omitted when Bisection has been used) +* + IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT. + $ RQTOL*ABS( LAMBDA ) .AND. .NOT. USEDBS) + $ THEN +* We need to check that the RQCORR update doesn't +* move the eigenvalue away from the desired one and +* towards a neighbor. -> protection with bisection + IF(INDEIG.LE.NEGCNT) THEN +* The wanted eigenvalue lies to the left + SGNDEF = -ONE + ELSE +* The wanted eigenvalue lies to the right + SGNDEF = ONE + ENDIF +* We only use the RQCORR if it improves the +* the iterate reasonably. + IF( ( RQCORR*SGNDEF.GE.ZERO ) + $ .AND.( LAMBDA + RQCORR.LE. RIGHT) + $ .AND.( LAMBDA + RQCORR.GE. LEFT) + $ ) THEN + USEDRQ = .TRUE. +* Store new midpoint of bisection interval in WORK + IF(SGNDEF.EQ.ONE) THEN +* The current LAMBDA is on the left of the true +* eigenvalue + LEFT = LAMBDA +* We prefer to assume that the error estimate +* is correct. We could make the interval not +* as a bracket but to be modified if the RQCORR +* chooses to. In this case, the RIGHT side should +* be modified as follows: +* RIGHT = MAX(RIGHT, LAMBDA + RQCORR) + ELSE +* The current LAMBDA is on the right of the true +* eigenvalue + RIGHT = LAMBDA +* See comment about assuming the error estimate is +* correct above. +* LEFT = MIN(LEFT, LAMBDA + RQCORR) + ENDIF + WORK( WINDEX ) = + $ HALF * (RIGHT + LEFT) +* Take RQCORR since it has the correct sign and +* improves the iterate reasonably + LAMBDA = LAMBDA + RQCORR +* Update width of error interval + WERR( WINDEX ) = + $ HALF * (RIGHT-LEFT) + ELSE + NEEDBS = .TRUE. + ENDIF + IF(RIGHT-LEFT.LT.RQTOL*ABS(LAMBDA)) THEN +* The eigenvalue is computed to bisection accuracy +* compute eigenvector and stop + USEDBS = .TRUE. + GOTO 120 + ELSEIF( ITER.LT.MAXITR ) THEN + GOTO 120 + ELSEIF( ITER.EQ.MAXITR ) THEN + NEEDBS = .TRUE. + GOTO 120 + ELSE + INFO = 5 + RETURN + END IF + ELSE + STP2II = .FALSE. + IF(USEDRQ .AND. USEDBS .AND. + $ BSTRES.LE.RESID) THEN + LAMBDA = BSTW + STP2II = .TRUE. + ENDIF + IF (STP2II) THEN +* improve error angle by second step + CALL DLAR1V( IN, 1, IN, LAMBDA, + $ D( IBEGIN ), L( IBEGIN ), + $ WORK(INDLD+IBEGIN-1), + $ WORK(INDLLD+IBEGIN-1), + $ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ), + $ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA, + $ IWORK( IINDR+WINDEX ), + $ ISUPPZ( 2*WINDEX-1 ), + $ NRMINV, RESID, RQCORR, WORK( INDWRK ) ) + ENDIF + WORK( WINDEX ) = LAMBDA + END IF +* +* Compute FP-vector support w.r.t. whole matrix +* + ISUPPZ( 2*WINDEX-1 ) = ISUPPZ( 2*WINDEX-1 )+OLDIEN + ISUPPZ( 2*WINDEX ) = ISUPPZ( 2*WINDEX )+OLDIEN + ZFROM = ISUPPZ( 2*WINDEX-1 ) + ZTO = ISUPPZ( 2*WINDEX ) + ISUPMN = ISUPMN + OLDIEN + ISUPMX = ISUPMX + OLDIEN +* Ensure vector is ok if support in the RQI has changed + IF(ISUPMN.LT.ZFROM) THEN + DO 122 II = ISUPMN,ZFROM-1 + Z( II, WINDEX ) = ZERO + 122 CONTINUE + ENDIF + IF(ISUPMX.GT.ZTO) THEN + DO 123 II = ZTO+1,ISUPMX + Z( II, WINDEX ) = ZERO + 123 CONTINUE + ENDIF + CALL DSCAL( ZTO-ZFROM+1, NRMINV, + $ Z( ZFROM, WINDEX ), 1 ) + 125 CONTINUE +* Update W + W( WINDEX ) = LAMBDA+SIGMA +* Recompute the gaps on the left and right +* But only allow them to become larger and not +* smaller (which can only happen through "bad" +* cancellation and doesn't reflect the theory +* where the initial gaps are underestimated due +* to WERR being too crude.) + IF(.NOT.ESKIP) THEN + IF( K.GT.1) THEN + WGAP( WINDMN ) = MAX( WGAP(WINDMN), + $ W(WINDEX)-WERR(WINDEX) + $ - W(WINDMN)-WERR(WINDMN) ) + ENDIF + IF( WINDEX.LT.WEND ) THEN + WGAP( WINDEX ) = MAX( SAVGAP, + $ W( WINDPL )-WERR( WINDPL ) + $ - W( WINDEX )-WERR( WINDEX) ) + ENDIF + ENDIF + IDONE = IDONE + 1 + ENDIF +* here ends the code for the current child +* + 139 CONTINUE +* Proceed to any remaining child nodes + NEWFST = J + 1 + 140 CONTINUE + 150 CONTINUE + NDEPTH = NDEPTH + 1 + GO TO 40 + END IF + IBEGIN = IEND + 1 + WBEGIN = WEND + 1 + 170 CONTINUE +* + + RETURN +* +* End of DLARRV +* + END diff --git a/math/lapack/src/main/fortran/dlarscl2.f b/math/lapack/src/main/fortran/dlarscl2.f new file mode 100644 index 0000000000..1b5ea53841 --- /dev/null +++ b/math/lapack/src/main/fortran/dlarscl2.f @@ -0,0 +1,119 @@ +*> \brief \b DLARSCL2 performs reciprocal diagonal scaling on a vector. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARSCL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARSCL2 ( M, N, D, X, LDX ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDX +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARSCL2 performs a reciprocal diagonal scaling on an vector: +*> x <-- inv(D) * x +*> where the diagonal matrix D is stored as a vector. +*> +*> Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS +*> standard. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of D and X. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of X. N >= 0. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (M) +*> Diagonal matrix D, stored as a vector of length M. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,N) +*> On entry, the vector X to be scaled by D. +*> On exit, the scaled vector. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the vector X. LDX >= M. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DLARSCL2 ( M, N, D, X, LDX ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER M, N, LDX +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* + DO J = 1, N + DO I = 1, M + X( I, J ) = X( I, J ) / D( I ) + END DO + END DO + + RETURN + END diff --git a/math/lapack/src/main/fortran/dlartg.f b/math/lapack/src/main/fortran/dlartg.f new file mode 100644 index 0000000000..1c7c46f638 --- /dev/null +++ b/math/lapack/src/main/fortran/dlartg.f @@ -0,0 +1,204 @@ +*> \brief \b DLARTG generates a plane rotation with real cosine and real sine. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARTG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARTG( F, G, CS, SN, R ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION CS, F, G, R, SN +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] F +*> \verbatim +*> F is DOUBLE PRECISION +*> The first component of vector to be rotated. +*> \endverbatim +*> +*> \param[in] G +*> \verbatim +*> G is DOUBLE PRECISION +*> The second component of vector to be rotated. +*> \endverbatim +*> +*> \param[out] CS +*> \verbatim +*> CS is DOUBLE PRECISION +*> The cosine of the rotation. +*> \endverbatim +*> +*> \param[out] SN +*> \verbatim +*> SN is DOUBLE PRECISION +*> The sine of the rotation. +*> \endverbatim +*> +*> \param[out] R +*> \verbatim +*> R is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLARTG( F, G, CS, SN, R ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION CS, F, G, R, SN +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlartgp.f b/math/lapack/src/main/fortran/dlartgp.f new file mode 100644 index 0000000000..0cb0d2d13f --- /dev/null +++ b/math/lapack/src/main/fortran/dlartgp.f @@ -0,0 +1,202 @@ +*> \brief \b DLARTGP generates a plane rotation so that the diagonal is nonnegative. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARTGP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARTGP( F, G, CS, SN, R ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION CS, F, G, R, SN +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARTGP generates 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 Level 1 BLAS 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. +*> +*> The sign is chosen so that R >= 0. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] F +*> \verbatim +*> F is DOUBLE PRECISION +*> The first component of vector to be rotated. +*> \endverbatim +*> +*> \param[in] G +*> \verbatim +*> G is DOUBLE PRECISION +*> The second component of vector to be rotated. +*> \endverbatim +*> +*> \param[out] CS +*> \verbatim +*> CS is DOUBLE PRECISION +*> The cosine of the rotation. +*> \endverbatim +*> +*> \param[out] SN +*> \verbatim +*> SN is DOUBLE PRECISION +*> The sine of the rotation. +*> \endverbatim +*> +*> \param[out] R +*> \verbatim +*> R is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLARTGP( F, G, CS, SN, R ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION CS, F, G, R, SN +* .. +* +* ===================================================================== +* +* .. 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, SIGN, 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 = SIGN( ONE, F ) + SN = ZERO + R = ABS( F ) + ELSE IF( F.EQ.ZERO ) THEN + CS = ZERO + SN = SIGN( ONE, G ) + R = ABS( 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( R.LT.ZERO ) THEN + CS = -CS + SN = -SN + R = -R + END IF + END IF + RETURN +* +* End of DLARTGP +* + END diff --git a/math/lapack/src/main/fortran/dlartgs.f b/math/lapack/src/main/fortran/dlartgs.f new file mode 100644 index 0000000000..a83e74d377 --- /dev/null +++ b/math/lapack/src/main/fortran/dlartgs.f @@ -0,0 +1,158 @@ +*> \brief \b DLARTGS generates a plane rotation designed to introduce a bulge in implicit QR iteration for the bidiagonal SVD problem. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARTGS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARTGS( X, Y, SIGMA, CS, SN ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION CS, SIGMA, SN, X, Y +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARTGS generates a plane rotation designed to introduce a bulge in +*> Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD +*> problem. X and Y are the top-row entries, and SIGMA is the shift. +*> The computed CS and SN define a plane rotation satisfying +*> +*> [ CS SN ] . [ X^2 - SIGMA ] = [ R ], +*> [ -SN CS ] [ X * Y ] [ 0 ] +*> +*> with R nonnegative. If X^2 - SIGMA and X * Y are 0, then the +*> rotation is by PI/2. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION +*> The (1,1) entry of an upper bidiagonal matrix. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is DOUBLE PRECISION +*> The (1,2) entry of an upper bidiagonal matrix. +*> \endverbatim +*> +*> \param[in] SIGMA +*> \verbatim +*> SIGMA is DOUBLE PRECISION +*> The shift. +*> \endverbatim +*> +*> \param[out] CS +*> \verbatim +*> CS is DOUBLE PRECISION +*> The cosine of the rotation. +*> \endverbatim +*> +*> \param[out] SN +*> \verbatim +*> SN is DOUBLE PRECISION +*> The sine of the rotation. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + SUBROUTINE DLARTGS( X, Y, SIGMA, CS, SN ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION CS, SIGMA, SN, X, Y +* .. +* +* =================================================================== +* +* .. Parameters .. + DOUBLE PRECISION NEGONE, ONE, ZERO + PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION R, S, THRESH, W, Z +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. Executable Statements .. +* + THRESH = DLAMCH('E') +* +* Compute the first column of B**T*B - SIGMA^2*I, up to a scale +* factor. +* + IF( (SIGMA .EQ. ZERO .AND. ABS(X) .LT. THRESH) .OR. + $ (ABS(X) .EQ. SIGMA .AND. Y .EQ. ZERO) ) THEN + Z = ZERO + W = ZERO + ELSE IF( SIGMA .EQ. ZERO ) THEN + IF( X .GE. ZERO ) THEN + Z = X + W = Y + ELSE + Z = -X + W = -Y + END IF + ELSE IF( ABS(X) .LT. THRESH ) THEN + Z = -SIGMA*SIGMA + W = ZERO + ELSE + IF( X .GE. ZERO ) THEN + S = ONE + ELSE + S = NEGONE + END IF + Z = S * (ABS(X)-SIGMA) * (S+SIGMA/X) + W = S * Y + END IF +* +* Generate the rotation. +* CALL DLARTGP( Z, W, CS, SN, R ) might seem more natural; +* reordering the arguments ensures that if Z = 0 then the rotation +* is by PI/2. +* + CALL DLARTGP( W, Z, SN, CS, R ) +* + RETURN +* +* End DLARTGS +* + END + diff --git a/math/lapack/src/main/fortran/dlartv.f b/math/lapack/src/main/fortran/dlartv.f new file mode 100644 index 0000000000..dca1cb7dcc --- /dev/null +++ b/math/lapack/src/main/fortran/dlartv.f @@ -0,0 +1,147 @@ +*> \brief \b DLARTV applies a vector of plane rotations with real cosines and real sines to the elements of a pair of vectors. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARTV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARTV( N, X, INCX, Y, INCY, C, S, INCC ) +* +* .. Scalar Arguments .. +* INTEGER INCC, INCX, INCY, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( * ), S( * ), X( * ), Y( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARTV applies a vector of real plane rotations to elements of the +*> real vectors x and y. For i = 1,2,...,n +*> +*> ( x(i) ) := ( c(i) s(i) ) ( x(i) ) +*> ( y(i) ) ( -s(i) c(i) ) ( y(i) ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of plane rotations to be applied. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, +*> dimension (1+(N-1)*INCX) +*> The vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The increment between elements of X. INCX > 0. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, +*> dimension (1+(N-1)*INCY) +*> The vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> The increment between elements of Y. INCY > 0. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC) +*> The cosines of the plane rotations. +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (1+(N-1)*INCC) +*> The sines of the plane rotations. +*> \endverbatim +*> +*> \param[in] INCC +*> \verbatim +*> INCC is INTEGER +*> The increment between elements of C and S. INCC > 0. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLARTV( N, X, INCX, Y, INCY, C, S, INCC ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCC, INCX, INCY, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( * ), S( * ), X( * ), Y( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IC, IX, IY + DOUBLE PRECISION XI, YI +* .. +* .. Executable Statements .. +* + IX = 1 + IY = 1 + IC = 1 + DO 10 I = 1, N + XI = X( IX ) + YI = Y( IY ) + X( IX ) = C( IC )*XI + S( IC )*YI + Y( IY ) = C( IC )*YI - S( IC )*XI + IX = IX + INCX + IY = IY + INCY + IC = IC + INCC + 10 CONTINUE + RETURN +* +* End of DLARTV +* + END diff --git a/math/lapack/src/main/fortran/dlaruv.f b/math/lapack/src/main/fortran/dlaruv.f new file mode 100644 index 0000000000..a903c186cb --- /dev/null +++ b/math/lapack/src/main/fortran/dlaruv.f @@ -0,0 +1,446 @@ +*> \brief \b DLARUV returns a vector of n random real numbers from a uniform distribution. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARUV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARUV( ISEED, N, X ) +* +* .. Scalar Arguments .. +* INTEGER N +* .. +* .. Array Arguments .. +* INTEGER ISEED( 4 ) +* DOUBLE PRECISION X( N ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARUV returns a vector of n random real numbers from a uniform (0,1) +*> distribution (n <= 128). +*> +*> This is an auxiliary routine called by DLARNV and ZLARNV. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry, the seed of the random number generator; the array +*> elements must be between 0 and 4095, and ISEED(4) must be +*> odd. +*> On exit, the seed is updated. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of random numbers to be generated. N <= 128. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (N) +*> The generated random numbers. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> This routine uses a multiplicative congruential method with modulus +*> 2**48 and multiplier 33952834046453 (see G.S.Fishman, +*> 'Multiplicative congruential random number generators with modulus +*> 2**b: an exhaustive analysis for b = 32 and a partial analysis for +*> b = 48', Math. Comp. 189, pp 331-344, 1990). +*> +*> 48-bit integers are stored in 4 integer array elements with 12 bits +*> per element. Hence the routine is portable across machines with +*> integers of 32 bits or more. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLARUV( ISEED, N, X ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER N +* .. +* .. Array Arguments .. + INTEGER ISEED( 4 ) + DOUBLE PRECISION X( N ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + INTEGER LV, IPW2 + DOUBLE PRECISION R + PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 ) +* .. +* .. Local Scalars .. + INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J +* .. +* .. Local Arrays .. + INTEGER MM( LV, 4 ) +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MIN, MOD +* .. +* .. Data statements .. + DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508, + $ 2549 / + DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754, + $ 1145 / + DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766, + $ 2253 / + DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572, + $ 305 / + DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893, + $ 3301 / + DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307, + $ 1065 / + DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297, + $ 3133 / + DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966, + $ 2913 / + DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758, + $ 3285 / + DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598, + $ 1241 / + DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406, + $ 1197 / + DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922, + $ 3729 / + DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038, + $ 2501 / + DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934, + $ 1673 / + DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091, + $ 541 / + DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451, + $ 2753 / + DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580, + $ 949 / + DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958, + $ 2361 / + DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055, + $ 1165 / + DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507, + $ 4081 / + DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078, + $ 2725 / + DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273, + $ 3305 / + DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17, + $ 3069 / + DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854, + $ 3617 / + DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916, + $ 3733 / + DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971, + $ 409 / + DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889, + $ 2157 / + DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831, + $ 1361 / + DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621, + $ 3973 / + DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541, + $ 1865 / + DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893, + $ 2525 / + DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736, + $ 1409 / + DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992, + $ 3445 / + DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787, + $ 3577 / + DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125, + $ 77 / + DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364, + $ 3761 / + DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460, + $ 2149 / + DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257, + $ 1449 / + DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574, + $ 3005 / + DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912, + $ 225 / + DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216, + $ 85 / + DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248, + $ 3673 / + DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401, + $ 3117 / + DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124, + $ 3089 / + DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762, + $ 1349 / + DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149, + $ 2057 / + DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245, + $ 413 / + DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166, + $ 65 / + DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466, + $ 1845 / + DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018, + $ 697 / + DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399, + $ 3085 / + DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190, + $ 3441 / + DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879, + $ 1573 / + DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153, + $ 3689 / + DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320, + $ 2941 / + DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18, + $ 929 / + DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712, + $ 533 / + DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159, + $ 2841 / + DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318, + $ 4077 / + DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091, + $ 721 / + DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443, + $ 2821 / + DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510, + $ 2249 / + DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449, + $ 2397 / + DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956, + $ 2817 / + DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201, + $ 245 / + DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137, + $ 1913 / + DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399, + $ 1997 / + DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321, + $ 3121 / + DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271, + $ 997 / + DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667, + $ 1833 / + DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703, + $ 2877 / + DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629, + $ 1633 / + DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365, + $ 981 / + DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431, + $ 2009 / + DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113, + $ 941 / + DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922, + $ 2449 / + DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554, + $ 197 / + DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184, + $ 2441 / + DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099, + $ 285 / + DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228, + $ 1473 / + DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012, + $ 2741 / + DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921, + $ 3129 / + DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452, + $ 909 / + DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901, + $ 2801 / + DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572, + $ 421 / + DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309, + $ 4073 / + DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171, + $ 2813 / + DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817, + $ 2337 / + DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039, + $ 1429 / + DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696, + $ 1177 / + DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256, + $ 1901 / + DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715, + $ 81 / + DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077, + $ 1669 / + DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019, + $ 2633 / + DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497, + $ 2269 / + DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101, + $ 129 / + DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717, + $ 1141 / + DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51, + $ 249 / + DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981, + $ 3917 / + DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978, + $ 2481 / + DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813, + $ 3941 / + DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881, + $ 2217 / + DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76, + $ 2749 / + DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846, + $ 3041 / + DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694, + $ 1877 / + DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682, + $ 345 / + DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124, + $ 2861 / + DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660, + $ 1809 / + DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997, + $ 3141 / + DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479, + $ 2825 / + DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141, + $ 157 / + DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886, + $ 2881 / + DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514, + $ 3637 / + DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301, + $ 1465 / + DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604, + $ 2829 / + DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888, + $ 2161 / + DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836, + $ 3365 / + DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990, + $ 361 / + DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058, + $ 2685 / + DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692, + $ 3745 / + DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194, + $ 2325 / + DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20, + $ 3609 / + DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285, + $ 3821 / + DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046, + $ 3537 / + DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107, + $ 517 / + DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508, + $ 3017 / + DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525, + $ 2141 / + DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801, + $ 1537 / +* .. +* .. Executable Statements .. +* + I1 = ISEED( 1 ) + I2 = ISEED( 2 ) + I3 = ISEED( 3 ) + I4 = ISEED( 4 ) +* + DO 10 I = 1, MIN( N, LV ) +* + 20 CONTINUE +* +* Multiply the seed by i-th power of the multiplier modulo 2**48 +* + IT4 = I4*MM( I, 4 ) + IT3 = IT4 / IPW2 + IT4 = IT4 - IPW2*IT3 + IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 ) + IT2 = IT3 / IPW2 + IT3 = IT3 - IPW2*IT2 + IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 ) + IT1 = IT2 / IPW2 + IT2 = IT2 - IPW2*IT1 + IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) + + $ I4*MM( I, 1 ) + IT1 = MOD( IT1, IPW2 ) +* +* Convert 48-bit integer to a real number in the interval (0,1) +* + X( I ) = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R* + $ DBLE( IT4 ) ) ) ) +* + IF (X( I ).EQ.1.0D0) THEN +* If a real number has n bits of precision, and the first +* n bits of the 48-bit integer above happen to be all 1 (which +* will occur about once every 2**n calls), then X( I ) will +* be rounded to exactly 1.0. +* Since X( I ) is not supposed to return exactly 0.0 or 1.0, +* the statistically correct thing to do in this situation is +* simply to iterate again. +* N.B. the case X( I ) = 0.0 should not be possible. + I1 = I1 + 2 + I2 = I2 + 2 + I3 = I3 + 2 + I4 = I4 + 2 + GOTO 20 + END IF +* + 10 CONTINUE +* +* Return final value of seed +* + ISEED( 1 ) = IT1 + ISEED( 2 ) = IT2 + ISEED( 3 ) = IT3 + ISEED( 4 ) = IT4 + RETURN +* +* End of DLARUV +* + END diff --git a/math/lapack/src/main/fortran/dlarz.f b/math/lapack/src/main/fortran/dlarz.f new file mode 100644 index 0000000000..73dc3f50df --- /dev/null +++ b/math/lapack/src/main/fortran/dlarz.f @@ -0,0 +1,236 @@ +*> \brief \b DLARZ applies an elementary reflector (as returned by stzrzf) to a general matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER INCV, L, LDC, M, N +* DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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**T +*> +*> where tau is a real scalar and v is a real vector. +*> +*> If tau = 0, then H is taken to be the unit matrix. +*> +*> +*> H is a product of k elementary reflectors as returned by DTZRZF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is 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. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is 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. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between elements of v. INCV <> 0. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, L, LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. 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 )**T * 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 )**T +* + 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 )**T +* + 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/math/lapack/src/main/fortran/dlarzb.f b/math/lapack/src/main/fortran/dlarzb.f new file mode 100644 index 0000000000..e34eef937f --- /dev/null +++ b/math/lapack/src/main/fortran/dlarzb.f @@ -0,0 +1,323 @@ +*> \brief \b DLARZB applies a block reflector or its transpose to a general matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARZB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, +* LDV, T, LDT, C, LDC, WORK, LDWORK ) +* +* .. 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply H or H**T from the Left +*> = 'R': apply H or H**T from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply H (No transpose) +*> = 'C': apply H**T (Transpose) +*> \endverbatim +*> +*> \param[in] DIRECT +*> \verbatim +*> DIRECT is 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) +*> \endverbatim +*> +*> \param[in] STOREV +*> \verbatim +*> STOREV is CHARACTER*1 +*> Indicates how the vectors which define the elementary +*> reflectors are stored: +*> = 'C': Columnwise (not supported yet) +*> = 'R': Rowwise +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The order of the matrix T (= the number of elementary +*> reflectors whose product defines the block reflector). +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is 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. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,NV). +*> If STOREV = 'C', NV = K; if STOREV = 'R', NV = L. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K. +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,K) +*> The triangular K-by-K matrix T in the representation of the +*> block reflector. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= K. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LDWORK,K) +*> \endverbatim +*> +*> \param[in] LDWORK +*> \verbatim +*> LDWORK is INTEGER +*> The leading dimension of the array WORK. +*> If SIDE = 'L', LDWORK >= max(1,N); +*> if SIDE = 'R', LDWORK >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, + $ LDV, T, LDT, C, LDC, WORK, LDWORK ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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, * ) +* .. +* +* ===================================================================== +* +* .. 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**T * C +* +* W( 1:n, 1:k ) = C( 1:k, 1:n )**T +* + 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 )**T * V( 1:k, 1:l )**T +* + 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**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 )**T +* + 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 )**T * W( 1:n, 1:k )**T +* + 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**T +* +* 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 )**T +* + 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**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/math/lapack/src/main/fortran/dlarzt.f b/math/lapack/src/main/fortran/dlarzt.f new file mode 100644 index 0000000000..5925569108 --- /dev/null +++ b/math/lapack/src/main/fortran/dlarzt.f @@ -0,0 +1,264 @@ +*> \brief \b DLARZT forms the triangular factor T of a block reflector H = I - vtvH. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARZT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* .. Scalar Arguments .. +* CHARACTER DIRECT, STOREV +* INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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**T +*> +*> 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 * T * V +*> +*> Currently, only STOREV = 'R' and DIRECT = 'B' are supported. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DIRECT +*> \verbatim +*> DIRECT is 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) +*> \endverbatim +*> +*> \param[in] STOREV +*> \verbatim +*> STOREV is CHARACTER*1 +*> Specifies how the vectors which define the elementary +*> reflectors are stored (see also Further Details): +*> = 'C': columnwise (not supported yet) +*> = 'R': rowwise +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the block reflector H. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The order of the triangular factor T (= the number of +*> elementary reflectors). K >= 1. +*> \endverbatim +*> +*> \param[in,out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension +*> (LDV,K) if STOREV = 'C' +*> (LDV,N) if STOREV = 'R' +*> The matrix V. See further details. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is 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. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= K. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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 ) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* ===================================================================== +* +* .. 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)**T +* + 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/math/lapack/src/main/fortran/dlas2.f b/math/lapack/src/main/fortran/dlas2.f new file mode 100644 index 0000000000..83873bc612 --- /dev/null +++ b/math/lapack/src/main/fortran/dlas2.f @@ -0,0 +1,183 @@ +*> \brief \b DLAS2 computes singular values of a 2-by-2 triangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION F, G, H, SSMAX, SSMIN +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] F +*> \verbatim +*> F is DOUBLE PRECISION +*> The (1,1) element of the 2-by-2 matrix. +*> \endverbatim +*> +*> \param[in] G +*> \verbatim +*> G is DOUBLE PRECISION +*> The (1,2) element of the 2-by-2 matrix. +*> \endverbatim +*> +*> \param[in] H +*> \verbatim +*> H is DOUBLE PRECISION +*> The (2,2) element of the 2-by-2 matrix. +*> \endverbatim +*> +*> \param[out] SSMIN +*> \verbatim +*> SSMIN is DOUBLE PRECISION +*> The smaller singular value. +*> \endverbatim +*> +*> \param[out] SSMAX +*> \verbatim +*> SSMAX is DOUBLE PRECISION +*> The larger singular value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION F, G, H, SSMAX, SSMIN +* .. +* +* ==================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlascl.f b/math/lapack/src/main/fortran/dlascl.f new file mode 100644 index 0000000000..03e1000a87 --- /dev/null +++ b/math/lapack/src/main/fortran/dlascl.f @@ -0,0 +1,368 @@ +*> \brief \b DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASCL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TYPE +* INTEGER INFO, KL, KU, LDA, M, N +* DOUBLE PRECISION CFROM, CTO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TYPE +*> \verbatim +*> TYPE is 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. See DGBTRF for storage details. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The lower bandwidth of A. Referenced only if TYPE = 'B', +*> 'Q' or 'Z'. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The upper bandwidth of A. Referenced only if TYPE = 'B', +*> 'Q' or 'Z'. +*> \endverbatim +*> +*> \param[in] CFROM +*> \verbatim +*> CFROM is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] CTO +*> \verbatim +*> CTO is 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. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The matrix to be multiplied by CTO/CFROM. See TYPE for the +*> storage type. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M); +*> TYPE = 'B', LDA >= KL+1; +*> TYPE = 'Q', LDA >= KU+1; +*> TYPE = 'Z', LDA >= 2*KL+KU+1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 0 - successful exit +*> <0 - if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, KL, KU, LDA, M, N + DOUBLE PRECISION CFROM, CTO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. 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, DISNAN + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH, DISNAN +* .. +* .. 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 .OR. DISNAN(CFROM) ) THEN + INFO = -4 + ELSE IF( DISNAN(CTO) ) THEN + INFO = -5 + 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 + IF( CFROM1.EQ.CFROMC ) THEN +! CFROMC is an inf. Multiply by a correctly signed zero for +! finite CTOC, or a NaN if CTOC is infinite. + MUL = CTOC / CFROMC + DONE = .TRUE. + CTO1 = CTOC + ELSE + CTO1 = CTOC / BIGNUM + IF( CTO1.EQ.CTOC ) THEN +! CTOC is either 0 or an inf. In both cases, CTOC itself +! serves as the correct multiplication factor. + MUL = CTOC + DONE = .TRUE. + CFROMC = ONE + ELSE 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 + 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/math/lapack/src/main/fortran/dlascl2.f b/math/lapack/src/main/fortran/dlascl2.f new file mode 100644 index 0000000000..ae88075305 --- /dev/null +++ b/math/lapack/src/main/fortran/dlascl2.f @@ -0,0 +1,119 @@ +*> \brief \b DLASCL2 performs diagonal scaling on a vector. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASCL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASCL2 ( M, N, D, X, LDX ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDX +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASCL2 performs a diagonal scaling on a vector: +*> x <-- D * x +*> where the diagonal matrix D is stored as a vector. +*> +*> Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS +*> standard. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of D and X. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of X. N >= 0. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, length M +*> Diagonal matrix D, stored as a vector of length M. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,N) +*> On entry, the vector X to be scaled by D. +*> On exit, the scaled vector. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the vector X. LDX >= M. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DLASCL2 ( M, N, D, X, LDX ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER M, N, LDX +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* + DO J = 1, N + DO I = 1, M + X( I, J ) = X( I, J ) * D( I ) + END DO + END DO + + RETURN + END diff --git a/math/lapack/src/main/fortran/dlasd0.f b/math/lapack/src/main/fortran/dlasd0.f new file mode 100644 index 0000000000..ca0b3b98c6 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasd0.f @@ -0,0 +1,318 @@ +*> \brief \b DLASD0 computes the singular values of a real upper bidiagonal n-by-m matrix B with diagonal d and off-diagonal e. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASD0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION D( * ), E( * ), U( LDU, * ), VT( LDVT, * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Using a divide and conquer approach, DLASD0 computes the singular +*> value decomposition (SVD) of a real upper bidiagonal N-by-M +*> matrix B with diagonal D and offdiagonal E, where M = N + SQRE. +*> The algorithm computes orthogonal matrices U and VT such that +*> B = U * S * VT. The singular values S are overwritten on D. +*> +*> A related subroutine, DLASDA, computes only the singular values, +*> and optionally, the singular vectors in compact form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, the row dimension of the upper bidiagonal matrix. +*> This is also the dimension of the main diagonal array D. +*> \endverbatim +*> +*> \param[in] SQRE +*> \verbatim +*> SQRE is INTEGER +*> Specifies the column dimension of the bidiagonal matrix. +*> = 0: The bidiagonal matrix has column dimension M = N; +*> = 1: The bidiagonal matrix has column dimension M = N+1; +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry D contains the main diagonal of the bidiagonal +*> matrix. +*> On exit D, if INFO = 0, contains its singular values. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (M-1) +*> Contains the subdiagonal entries of the bidiagonal matrix. +*> On exit, E has been destroyed. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension at least (LDQ, N) +*> On exit, U contains the left singular vectors. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> On entry, leading dimension of U. +*> \endverbatim +*> +*> \param[out] VT +*> \verbatim +*> VT is DOUBLE PRECISION array, dimension at least (LDVT, M) +*> On exit, VT**T contains the right singular vectors. +*> \endverbatim +*> +*> \param[in] LDVT +*> \verbatim +*> LDVT is INTEGER +*> On entry, leading dimension of VT. +*> \endverbatim +*> +*> \param[in] SMLSIZ +*> \verbatim +*> SMLSIZ is INTEGER +*> On entry, maximum size of the subproblems at the +*> bottom of the computation tree. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER work array. +*> Dimension must be at least (8 * N) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION work array. +*> Dimension must be at least (3 * M**2 + 2 * M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = 1, a singular value did not converge +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, + $ WORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), U( LDU, * ), VT( LDVT, * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK, + $ J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR, + $ NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI + DOUBLE PRECISION ALPHA, BETA +* .. +* .. External Subroutines .. + EXTERNAL DLASD1, DLASDQ, DLASDT, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -2 + END IF +* + M = N + SQRE +* + IF( LDU.LT.N ) THEN + INFO = -6 + ELSE IF( LDVT.LT.M ) THEN + INFO = -8 + ELSE IF( SMLSIZ.LT.3 ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD0', -INFO ) + RETURN + END IF +* +* If the input matrix is too small, call DLASDQ to find the SVD. +* + IF( N.LE.SMLSIZ ) THEN + CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDVT, U, LDU, U, + $ LDU, WORK, INFO ) + RETURN + END IF +* +* Set up the computation tree. +* + INODE = 1 + NDIML = INODE + N + NDIMR = NDIML + N + IDXQ = NDIMR + N + IWK = IDXQ + N + CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), + $ IWORK( NDIMR ), SMLSIZ ) +* +* For the nodes on bottom level of the tree, solve +* their subproblems by DLASDQ. +* + NDB1 = ( ND+1 ) / 2 + NCC = 0 + DO 30 I = NDB1, ND +* +* IC : center row of each node +* NL : number of rows of left subproblem +* NR : number of rows of right subproblem +* NLF: starting row of the left subproblem +* NRF: starting row of the right subproblem +* + I1 = I - 1 + IC = IWORK( INODE+I1 ) + NL = IWORK( NDIML+I1 ) + NLP1 = NL + 1 + NR = IWORK( NDIMR+I1 ) + NRP1 = NR + 1 + NLF = IC - NL + NRF = IC + 1 + SQREI = 1 + CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), E( NLF ), + $ VT( NLF, NLF ), LDVT, U( NLF, NLF ), LDU, + $ U( NLF, NLF ), LDU, WORK, INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + ITEMP = IDXQ + NLF - 2 + DO 10 J = 1, NL + IWORK( ITEMP+J ) = J + 10 CONTINUE + IF( I.EQ.ND ) THEN + SQREI = SQRE + ELSE + SQREI = 1 + END IF + NRP1 = NR + SQREI + CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), E( NRF ), + $ VT( NRF, NRF ), LDVT, U( NRF, NRF ), LDU, + $ U( NRF, NRF ), LDU, WORK, INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + ITEMP = IDXQ + IC + DO 20 J = 1, NR + IWORK( ITEMP+J-1 ) = J + 20 CONTINUE + 30 CONTINUE +* +* Now conquer each subproblem bottom-up. +* + DO 50 LVL = NLVL, 1, -1 +* +* Find the first node LF and last node LL on the +* current level LVL. +* + IF( LVL.EQ.1 ) THEN + LF = 1 + LL = 1 + ELSE + LF = 2**( LVL-1 ) + LL = 2*LF - 1 + END IF + DO 40 I = LF, LL + IM1 = I - 1 + IC = IWORK( INODE+IM1 ) + NL = IWORK( NDIML+IM1 ) + NR = IWORK( NDIMR+IM1 ) + NLF = IC - NL + IF( ( SQRE.EQ.0 ) .AND. ( I.EQ.LL ) ) THEN + SQREI = SQRE + ELSE + SQREI = 1 + END IF + IDXQC = IDXQ + NLF - 1 + ALPHA = D( IC ) + BETA = E( IC ) + CALL DLASD1( NL, NR, SQREI, D( NLF ), ALPHA, BETA, + $ U( NLF, NLF ), LDU, VT( NLF, NLF ), LDVT, + $ IWORK( IDXQC ), IWORK( IWK ), WORK, INFO ) +* +* Report the possible convergence failure. +* + IF( INFO.NE.0 ) THEN + RETURN + END IF + 40 CONTINUE + 50 CONTINUE +* + RETURN +* +* End of DLASD0 +* + END diff --git a/math/lapack/src/main/fortran/dlasd1.f b/math/lapack/src/main/fortran/dlasd1.f new file mode 100644 index 0000000000..fe8aad9597 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasd1.f @@ -0,0 +1,326 @@ +*> \brief \b DLASD1 computes the SVD of an upper bidiagonal matrix B of the specified size. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASD1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, +* IDXQ, IWORK, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDU, LDVT, NL, NR, SQRE +* DOUBLE PRECISION ALPHA, BETA +* .. +* .. Array Arguments .. +* INTEGER IDXQ( * ), IWORK( * ) +* DOUBLE PRECISION D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B, +*> where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0. +*> +*> A related subroutine DLASD7 handles the case in which the singular +*> values (and the singular vectors in factored form) are desired. +*> +*> DLASD1 computes the SVD as follows: +*> +*> ( D1(in) 0 0 0 ) +*> B = U(in) * ( Z1**T a Z2**T b ) * VT(in) +*> ( 0 0 D2(in) 0 ) +*> +*> = U(out) * ( D(out) 0) * VT(out) +*> +*> where Z**T = (Z1**T a Z2**T b) = u**T VT**T, and u is a vector of dimension M +*> with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros +*> elsewhere; and the entry b is empty if SQRE = 0. +*> +*> The left singular vectors of the original matrix are stored in U, and +*> the transpose of the right singular vectors are stored in VT, and the +*> singular values are in D. The algorithm consists of three stages: +*> +*> The first stage consists of deflating the size of the problem +*> when there are multiple singular values or when there are zeros in +*> the Z vector. For each such occurrence the dimension of the +*> secular equation problem is reduced by one. This stage is +*> performed by the routine DLASD2. +*> +*> The second stage consists of calculating the updated +*> singular values. This is done by finding the square roots of the +*> roots of the secular equation via the routine DLASD4 (as called +*> by DLASD3). This routine also calculates the singular vectors of +*> the current problem. +*> +*> The final stage consists of computing the updated singular vectors +*> directly using the updated singular values. The singular vectors +*> for the current problem are multiplied with the singular vectors +*> from the overall problem. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NL +*> \verbatim +*> NL is INTEGER +*> The row dimension of the upper block. NL >= 1. +*> \endverbatim +*> +*> \param[in] NR +*> \verbatim +*> NR is INTEGER +*> The row dimension of the lower block. NR >= 1. +*> \endverbatim +*> +*> \param[in] SQRE +*> \verbatim +*> SQRE is INTEGER +*> = 0: the lower block is an NR-by-NR square matrix. +*> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. +*> +*> The bidiagonal matrix has row dimension N = NL + NR + 1, +*> and column dimension M = N + SQRE. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, +*> dimension (N = NL+NR+1). +*> On entry D(1:NL,1:NL) contains the singular values of the +*> upper block; and D(NL+2:N) contains the singular values of +*> the lower block. On exit D(1:N) contains the singular values +*> of the modified matrix. +*> \endverbatim +*> +*> \param[in,out] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> Contains the diagonal element associated with the added row. +*> \endverbatim +*> +*> \param[in,out] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION +*> Contains the off-diagonal element associated with the added +*> row. +*> \endverbatim +*> +*> \param[in,out] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension(LDU,N) +*> On entry U(1:NL, 1:NL) contains the left singular vectors of +*> the upper block; U(NL+2:N, NL+2:N) contains the left singular +*> vectors of the lower block. On exit U contains the left +*> singular vectors of the bidiagonal matrix. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of the array U. LDU >= max( 1, N ). +*> \endverbatim +*> +*> \param[in,out] VT +*> \verbatim +*> VT is DOUBLE PRECISION array, dimension(LDVT,M) +*> where M = N + SQRE. +*> On entry VT(1:NL+1, 1:NL+1)**T contains the right singular +*> vectors of the upper block; VT(NL+2:M, NL+2:M)**T contains +*> the right singular vectors of the lower block. On exit +*> VT**T contains the right singular vectors of the +*> bidiagonal matrix. +*> \endverbatim +*> +*> \param[in] LDVT +*> \verbatim +*> LDVT is INTEGER +*> The leading dimension of the array VT. LDVT >= max( 1, M ). +*> \endverbatim +*> +*> \param[in,out] IDXQ +*> \verbatim +*> IDXQ is INTEGER array, dimension(N) +*> This contains the permutation which will reintegrate the +*> subproblem just solved back into sorted order, i.e. +*> D( IDXQ( I = 1, N ) ) will be in ascending order. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension( 4 * N ) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension( 3*M**2 + 2*M ) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = 1, a singular value did not converge +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, + $ IDXQ, IWORK, WORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDU, LDVT, NL, NR, SQRE + DOUBLE PRECISION ALPHA, BETA +* .. +* .. Array Arguments .. + INTEGER IDXQ( * ), IWORK( * ) + DOUBLE PRECISION D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. +* + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2, + $ IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2 + DOUBLE PRECISION ORGNRM +* .. +* .. External Subroutines .. + EXTERNAL DLAMRG, DLASCL, DLASD2, DLASD3, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( NL.LT.1 ) THEN + INFO = -1 + ELSE IF( NR.LT.1 ) THEN + INFO = -2 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD1', -INFO ) + RETURN + END IF +* + N = NL + NR + 1 + M = N + SQRE +* +* The following values are for bookkeeping purposes only. They are +* integer pointers which indicate the portion of the workspace +* used by a particular array in DLASD2 and DLASD3. +* + LDU2 = N + LDVT2 = M +* + IZ = 1 + ISIGMA = IZ + M + IU2 = ISIGMA + N + IVT2 = IU2 + LDU2*N + IQ = IVT2 + LDVT2*M +* + IDX = 1 + IDXC = IDX + N + COLTYP = IDXC + N + IDXP = COLTYP + N +* +* Scale. +* + ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) ) + D( NL+1 ) = ZERO + DO 10 I = 1, N + IF( ABS( D( I ) ).GT.ORGNRM ) THEN + ORGNRM = ABS( D( I ) ) + END IF + 10 CONTINUE + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO ) + ALPHA = ALPHA / ORGNRM + BETA = BETA / ORGNRM +* +* Deflate singular values. +* + CALL DLASD2( NL, NR, SQRE, K, D, WORK( IZ ), ALPHA, BETA, U, LDU, + $ VT, LDVT, WORK( ISIGMA ), WORK( IU2 ), LDU2, + $ WORK( IVT2 ), LDVT2, IWORK( IDXP ), IWORK( IDX ), + $ IWORK( IDXC ), IDXQ, IWORK( COLTYP ), INFO ) +* +* Solve Secular Equation and update singular vectors. +* + LDQ = K + CALL DLASD3( NL, NR, SQRE, K, D, WORK( IQ ), LDQ, WORK( ISIGMA ), + $ U, LDU, WORK( IU2 ), LDU2, VT, LDVT, WORK( IVT2 ), + $ LDVT2, IWORK( IDXC ), IWORK( COLTYP ), WORK( IZ ), + $ INFO ) +* +* Report the convergence failure. +* + IF( INFO.NE.0 ) THEN + RETURN + END IF +* +* Unscale. +* + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) +* +* Prepare the IDXQ sorting permutation. +* + N1 = K + N2 = N - K + CALL DLAMRG( N1, N2, D, 1, -1, IDXQ ) +* + RETURN +* +* End of DLASD1 +* + END diff --git a/math/lapack/src/main/fortran/dlasd2.f b/math/lapack/src/main/fortran/dlasd2.f new file mode 100644 index 0000000000..a7ced418f7 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasd2.f @@ -0,0 +1,634 @@ +*> \brief \b DLASD2 merges the two sets of singular values together into a single sorted set. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, +* LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, +* IDXC, IDXQ, COLTYP, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE +* DOUBLE PRECISION ALPHA, BETA +* .. +* .. Array Arguments .. +* INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ), +* $ IDXQ( * ) +* DOUBLE PRECISION D( * ), DSIGMA( * ), U( LDU, * ), +* $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), +* $ Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASD2 merges the two sets of singular values together into a single +*> sorted set. Then it tries to deflate the size of the problem. +*> There are two ways in which deflation can occur: when two or more +*> singular values are close together or if there is a tiny entry in the +*> Z vector. For each such occurrence the order of the related secular +*> equation problem is reduced by one. +*> +*> DLASD2 is called from DLASD1. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NL +*> \verbatim +*> NL is INTEGER +*> The row dimension of the upper block. NL >= 1. +*> \endverbatim +*> +*> \param[in] NR +*> \verbatim +*> NR is INTEGER +*> The row dimension of the lower block. NR >= 1. +*> \endverbatim +*> +*> \param[in] SQRE +*> \verbatim +*> SQRE is INTEGER +*> = 0: the lower block is an NR-by-NR square matrix. +*> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. +*> +*> The bidiagonal matrix has N = NL + NR + 1 rows and +*> M = N + SQRE >= N columns. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Contains the dimension of the non-deflated matrix, +*> This is the order of the related secular equation. 1 <= K <=N. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension(N) +*> On entry D contains the singular values of the two submatrices +*> to be combined. On exit D contains the trailing (N-K) updated +*> singular values (those which were deflated) sorted into +*> increasing order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension(N) +*> On exit Z contains the updating row vector in the secular +*> equation. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> Contains the diagonal element associated with the added row. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION +*> Contains the off-diagonal element associated with the added +*> row. +*> \endverbatim +*> +*> \param[in,out] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension(LDU,N) +*> On entry U contains the left singular vectors of two +*> submatrices in the two square blocks with corners at (1,1), +*> (NL, NL), and (NL+2, NL+2), (N,N). +*> On exit U contains the trailing (N-K) updated left singular +*> vectors (those which were deflated) in its last N-K columns. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of the array U. LDU >= N. +*> \endverbatim +*> +*> \param[in,out] VT +*> \verbatim +*> VT is DOUBLE PRECISION array, dimension(LDVT,M) +*> On entry VT**T contains the right singular vectors of two +*> submatrices in the two square blocks with corners at (1,1), +*> (NL+1, NL+1), and (NL+2, NL+2), (M,M). +*> On exit VT**T contains the trailing (N-K) updated right singular +*> vectors (those which were deflated) in its last N-K columns. +*> In case SQRE =1, the last row of VT spans the right null +*> space. +*> \endverbatim +*> +*> \param[in] LDVT +*> \verbatim +*> LDVT is INTEGER +*> The leading dimension of the array VT. LDVT >= M. +*> \endverbatim +*> +*> \param[out] DSIGMA +*> \verbatim +*> DSIGMA is DOUBLE PRECISION array, dimension (N) +*> Contains a copy of the diagonal elements (K-1 singular values +*> and one zero) in the secular equation. +*> \endverbatim +*> +*> \param[out] U2 +*> \verbatim +*> U2 is DOUBLE PRECISION array, dimension(LDU2,N) +*> Contains a copy of the first K-1 left singular vectors which +*> will be used by DLASD3 in a matrix multiply (DGEMM) to solve +*> for the new left singular vectors. U2 is arranged into four +*> blocks. The first block contains a column with 1 at NL+1 and +*> zero everywhere else; the second block contains non-zero +*> entries only at and above NL; the third contains non-zero +*> entries only below NL+1; and the fourth is dense. +*> \endverbatim +*> +*> \param[in] LDU2 +*> \verbatim +*> LDU2 is INTEGER +*> The leading dimension of the array U2. LDU2 >= N. +*> \endverbatim +*> +*> \param[out] VT2 +*> \verbatim +*> VT2 is DOUBLE PRECISION array, dimension(LDVT2,N) +*> VT2**T contains a copy of the first K right singular vectors +*> which will be used by DLASD3 in a matrix multiply (DGEMM) to +*> solve for the new right singular vectors. VT2 is arranged into +*> three blocks. The first block contains a row that corresponds +*> to the special 0 diagonal element in SIGMA; the second block +*> contains non-zeros only at and before NL +1; the third block +*> contains non-zeros only at and after NL +2. +*> \endverbatim +*> +*> \param[in] LDVT2 +*> \verbatim +*> LDVT2 is INTEGER +*> The leading dimension of the array VT2. LDVT2 >= M. +*> \endverbatim +*> +*> \param[out] IDXP +*> \verbatim +*> IDXP is INTEGER array dimension(N) +*> This will contain the permutation used to place deflated +*> values of D at the end of the array. On output IDXP(2:K) +*> points to the nondeflated D-values and IDXP(K+1:N) +*> points to the deflated singular values. +*> \endverbatim +*> +*> \param[out] IDX +*> \verbatim +*> IDX is INTEGER array dimension(N) +*> This will contain the permutation used to sort the contents of +*> D into ascending order. +*> \endverbatim +*> +*> \param[out] IDXC +*> \verbatim +*> IDXC is INTEGER array dimension(N) +*> This will contain the permutation used to arrange the columns +*> of the deflated U matrix into three groups: the first group +*> contains non-zero entries only at and above NL, the second +*> contains non-zero entries only below NL+2, and the third is +*> dense. +*> \endverbatim +*> +*> \param[in,out] IDXQ +*> \verbatim +*> IDXQ is INTEGER array dimension(N) +*> This contains the permutation which separately sorts the two +*> sub-problems in D into ascending order. Note that entries in +*> the first hlaf of this permutation must first be moved one +*> position backward; and entries in the second half +*> must first have NL+1 added to their values. +*> \endverbatim +*> +*> \param[out] COLTYP +*> \verbatim +*> COLTYP is INTEGER array dimension(N) +*> As workspace, this will contain a label which will indicate +*> which of the following types a column in the U2 matrix or a +*> row in the VT2 matrix is: +*> 1 : non-zero in the upper half only +*> 2 : non-zero in the lower half only +*> 3 : dense +*> 4 : deflated +*> +*> On exit, it is an array of dimension 4, with COLTYP(I) being +*> the dimension of the I-th type columns. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, + $ LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, + $ IDXC, IDXQ, COLTYP, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE + DOUBLE PRECISION ALPHA, BETA +* .. +* .. Array Arguments .. + INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ), + $ IDXQ( * ) + DOUBLE PRECISION D( * ), DSIGMA( * ), U( LDU, * ), + $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), + $ Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, EIGHT + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ EIGHT = 8.0D+0 ) +* .. +* .. Local Arrays .. + INTEGER CTOT( 4 ), PSM( 4 ) +* .. +* .. Local Scalars .. + INTEGER CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, + $ N, NLP1, NLP2 + DOUBLE PRECISION C, EPS, HLFTOL, S, TAU, TOL, Z1 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DLAMRG, DLASET, DROT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( NL.LT.1 ) THEN + INFO = -1 + ELSE IF( NR.LT.1 ) THEN + INFO = -2 + ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN + INFO = -3 + END IF +* + N = NL + NR + 1 + M = N + SQRE +* + IF( LDU.LT.N ) THEN + INFO = -10 + ELSE IF( LDVT.LT.M ) THEN + INFO = -12 + ELSE IF( LDU2.LT.N ) THEN + INFO = -15 + ELSE IF( LDVT2.LT.M ) THEN + INFO = -17 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD2', -INFO ) + RETURN + END IF +* + NLP1 = NL + 1 + NLP2 = NL + 2 +* +* Generate the first part of the vector Z; and move the singular +* values in the first part of D one position backward. +* + Z1 = ALPHA*VT( NLP1, NLP1 ) + Z( 1 ) = Z1 + DO 10 I = NL, 1, -1 + Z( I+1 ) = ALPHA*VT( I, NLP1 ) + D( I+1 ) = D( I ) + IDXQ( I+1 ) = IDXQ( I ) + 1 + 10 CONTINUE +* +* Generate the second part of the vector Z. +* + DO 20 I = NLP2, M + Z( I ) = BETA*VT( I, NLP2 ) + 20 CONTINUE +* +* Initialize some reference arrays. +* + DO 30 I = 2, NLP1 + COLTYP( I ) = 1 + 30 CONTINUE + DO 40 I = NLP2, N + COLTYP( I ) = 2 + 40 CONTINUE +* +* Sort the singular values into increasing order +* + DO 50 I = NLP2, N + IDXQ( I ) = IDXQ( I ) + NLP1 + 50 CONTINUE +* +* DSIGMA, IDXC, IDXC, and the first column of U2 +* are used as storage space. +* + DO 60 I = 2, N + DSIGMA( I ) = D( IDXQ( I ) ) + U2( I, 1 ) = Z( IDXQ( I ) ) + IDXC( I ) = COLTYP( IDXQ( I ) ) + 60 CONTINUE +* + CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) ) +* + DO 70 I = 2, N + IDXI = 1 + IDX( I ) + D( I ) = DSIGMA( IDXI ) + Z( I ) = U2( IDXI, 1 ) + COLTYP( I ) = IDXC( IDXI ) + 70 CONTINUE +* +* Calculate the allowable deflation tolerance +* + EPS = DLAMCH( 'Epsilon' ) + TOL = MAX( ABS( ALPHA ), ABS( BETA ) ) + TOL = EIGHT*EPS*MAX( ABS( D( N ) ), TOL ) +* +* There are 2 kinds of deflation -- first a value in the z-vector +* is small, second two (or more) singular values are very close +* together (their difference is small). +* +* If the value in the z-vector is small, we simply permute the +* array so that the corresponding singular value is moved to the +* end. +* +* If two values in the D-vector are close, we perform a two-sided +* rotation designed to make one of the corresponding z-vector +* entries zero, and then permute the array so that the deflated +* singular value is moved to the end. +* +* If there are multiple singular values then the problem deflates. +* Here the number of equal singular values are found. As each equal +* singular value is found, an elementary reflector is computed to +* rotate the corresponding singular subspace so that the +* corresponding components of Z are zero in this new basis. +* + K = 1 + K2 = N + 1 + DO 80 J = 2, N + IF( ABS( Z( J ) ).LE.TOL ) THEN +* +* Deflate due to small z component. +* + K2 = K2 - 1 + IDXP( K2 ) = J + COLTYP( J ) = 4 + IF( J.EQ.N ) + $ GO TO 120 + ELSE + JPREV = J + GO TO 90 + END IF + 80 CONTINUE + 90 CONTINUE + J = JPREV + 100 CONTINUE + J = J + 1 + IF( J.GT.N ) + $ GO TO 110 + IF( ABS( Z( J ) ).LE.TOL ) THEN +* +* Deflate due to small z component. +* + K2 = K2 - 1 + IDXP( K2 ) = J + COLTYP( J ) = 4 + ELSE +* +* Check if singular values are close enough to allow deflation. +* + IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN +* +* Deflation is possible. +* + S = Z( JPREV ) + C = Z( J ) +* +* Find sqrt(a**2+b**2) without overflow or +* destructive underflow. +* + TAU = DLAPY2( C, S ) + C = C / TAU + S = -S / TAU + Z( J ) = TAU + Z( JPREV ) = ZERO +* +* Apply back the Givens rotation to the left and right +* singular vector matrices. +* + IDXJP = IDXQ( IDX( JPREV )+1 ) + IDXJ = IDXQ( IDX( J )+1 ) + IF( IDXJP.LE.NLP1 ) THEN + IDXJP = IDXJP - 1 + END IF + IF( IDXJ.LE.NLP1 ) THEN + IDXJ = IDXJ - 1 + END IF + CALL DROT( N, U( 1, IDXJP ), 1, U( 1, IDXJ ), 1, C, S ) + CALL DROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, C, + $ S ) + IF( COLTYP( J ).NE.COLTYP( JPREV ) ) THEN + COLTYP( J ) = 3 + END IF + COLTYP( JPREV ) = 4 + K2 = K2 - 1 + IDXP( K2 ) = JPREV + JPREV = J + ELSE + K = K + 1 + U2( K, 1 ) = Z( JPREV ) + DSIGMA( K ) = D( JPREV ) + IDXP( K ) = JPREV + JPREV = J + END IF + END IF + GO TO 100 + 110 CONTINUE +* +* Record the last singular value. +* + K = K + 1 + U2( K, 1 ) = Z( JPREV ) + DSIGMA( K ) = D( JPREV ) + IDXP( K ) = JPREV +* + 120 CONTINUE +* +* Count up the total number of the various types of columns, then +* form a permutation which positions the four column types into +* four groups of uniform structure (although one or more of these +* groups may be empty). +* + DO 130 J = 1, 4 + CTOT( J ) = 0 + 130 CONTINUE + DO 140 J = 2, N + CT = COLTYP( J ) + CTOT( CT ) = CTOT( CT ) + 1 + 140 CONTINUE +* +* PSM(*) = Position in SubMatrix (of types 1 through 4) +* + PSM( 1 ) = 2 + PSM( 2 ) = 2 + CTOT( 1 ) + PSM( 3 ) = PSM( 2 ) + CTOT( 2 ) + PSM( 4 ) = PSM( 3 ) + CTOT( 3 ) +* +* Fill out the IDXC array so that the permutation which it induces +* will place all type-1 columns first, all type-2 columns next, +* then all type-3's, and finally all type-4's, starting from the +* second column. This applies similarly to the rows of VT. +* + DO 150 J = 2, N + JP = IDXP( J ) + CT = COLTYP( JP ) + IDXC( PSM( CT ) ) = J + PSM( CT ) = PSM( CT ) + 1 + 150 CONTINUE +* +* Sort the singular values and corresponding singular vectors into +* DSIGMA, U2, and VT2 respectively. The singular values/vectors +* which were not deflated go into the first K slots of DSIGMA, U2, +* and VT2 respectively, while those which were deflated go into the +* last N - K slots, except that the first column/row will be treated +* separately. +* + DO 160 J = 2, N + JP = IDXP( J ) + DSIGMA( J ) = D( JP ) + IDXJ = IDXQ( IDX( IDXP( IDXC( J ) ) )+1 ) + IF( IDXJ.LE.NLP1 ) THEN + IDXJ = IDXJ - 1 + END IF + CALL DCOPY( N, U( 1, IDXJ ), 1, U2( 1, J ), 1 ) + CALL DCOPY( M, VT( IDXJ, 1 ), LDVT, VT2( J, 1 ), LDVT2 ) + 160 CONTINUE +* +* Determine DSIGMA(1), DSIGMA(2) and Z(1) +* + DSIGMA( 1 ) = ZERO + HLFTOL = TOL / TWO + IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL ) + $ DSIGMA( 2 ) = HLFTOL + IF( M.GT.N ) THEN + Z( 1 ) = DLAPY2( Z1, Z( M ) ) + IF( Z( 1 ).LE.TOL ) THEN + C = ONE + S = ZERO + Z( 1 ) = TOL + ELSE + C = Z1 / Z( 1 ) + S = Z( M ) / Z( 1 ) + END IF + ELSE + IF( ABS( Z1 ).LE.TOL ) THEN + Z( 1 ) = TOL + ELSE + Z( 1 ) = Z1 + END IF + END IF +* +* Move the rest of the updating row to Z. +* + CALL DCOPY( K-1, U2( 2, 1 ), 1, Z( 2 ), 1 ) +* +* Determine the first column of U2, the first row of VT2 and the +* last row of VT. +* + CALL DLASET( 'A', N, 1, ZERO, ZERO, U2, LDU2 ) + U2( NLP1, 1 ) = ONE + IF( M.GT.N ) THEN + DO 170 I = 1, NLP1 + VT( M, I ) = -S*VT( NLP1, I ) + VT2( 1, I ) = C*VT( NLP1, I ) + 170 CONTINUE + DO 180 I = NLP2, M + VT2( 1, I ) = S*VT( M, I ) + VT( M, I ) = C*VT( M, I ) + 180 CONTINUE + ELSE + CALL DCOPY( M, VT( NLP1, 1 ), LDVT, VT2( 1, 1 ), LDVT2 ) + END IF + IF( M.GT.N ) THEN + CALL DCOPY( M, VT( M, 1 ), LDVT, VT2( M, 1 ), LDVT2 ) + END IF +* +* The deflated singular values and their corresponding vectors go +* into the back of D, U, and V respectively. +* + IF( N.GT.K ) THEN + CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 ) + CALL DLACPY( 'A', N, N-K, U2( 1, K+1 ), LDU2, U( 1, K+1 ), + $ LDU ) + CALL DLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, 1 ), + $ LDVT ) + END IF +* +* Copy CTOT into COLTYP for referencing in DLASD3. +* + DO 190 J = 1, 4 + COLTYP( J ) = CTOT( J ) + 190 CONTINUE +* + RETURN +* +* End of DLASD2 +* + END diff --git a/math/lapack/src/main/fortran/dlasd3.f b/math/lapack/src/main/fortran/dlasd3.f new file mode 100644 index 0000000000..57d0abd4cd --- /dev/null +++ b/math/lapack/src/main/fortran/dlasd3.f @@ -0,0 +1,470 @@ +*> \brief \b DLASD3 finds all square roots of the roots of the secular equation, as defined by the values in D and Z, and then updates the singular vectors by matrix multiplication. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASD3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, +* LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR, +* $ SQRE +* .. +* .. Array Arguments .. +* INTEGER CTOT( * ), IDXC( * ) +* DOUBLE PRECISION D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ), +* $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), +* $ Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASD3 finds all the square roots of the roots of the secular +*> equation, as defined by the values in D and Z. It makes the +*> appropriate calls to DLASD4 and then updates the singular +*> vectors by matrix multiplication. +*> +*> This code makes very mild assumptions about floating point +*> arithmetic. It will work on machines with a guard digit in +*> add/subtract, or on those binary machines without guard digits +*> which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. +*> It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> +*> DLASD3 is called from DLASD1. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NL +*> \verbatim +*> NL is INTEGER +*> The row dimension of the upper block. NL >= 1. +*> \endverbatim +*> +*> \param[in] NR +*> \verbatim +*> NR is INTEGER +*> The row dimension of the lower block. NR >= 1. +*> \endverbatim +*> +*> \param[in] SQRE +*> \verbatim +*> SQRE is INTEGER +*> = 0: the lower block is an NR-by-NR square matrix. +*> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. +*> +*> The bidiagonal matrix has N = NL + NR + 1 rows and +*> M = N + SQRE >= N columns. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The size of the secular equation, 1 =< K = < N. +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension(K) +*> On exit the square roots of the roots of the secular equation, +*> in ascending order. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, +*> dimension at least (LDQ,K). +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= K. +*> \endverbatim +*> +*> \param[in] DSIGMA +*> \verbatim +*> DSIGMA is DOUBLE PRECISION array, dimension(K) +*> The first K elements of this array contain the old roots +*> of the deflated updating problem. These are the poles +*> of the secular equation. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension (LDU, N) +*> The last N - K columns of this matrix contain the deflated +*> left singular vectors. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of the array U. LDU >= N. +*> \endverbatim +*> +*> \param[in,out] U2 +*> \verbatim +*> U2 is DOUBLE PRECISION array, dimension (LDU2, N) +*> The first K columns of this matrix contain the non-deflated +*> left singular vectors for the split problem. +*> \endverbatim +*> +*> \param[in] LDU2 +*> \verbatim +*> LDU2 is INTEGER +*> The leading dimension of the array U2. LDU2 >= N. +*> \endverbatim +*> +*> \param[out] VT +*> \verbatim +*> VT is DOUBLE PRECISION array, dimension (LDVT, M) +*> The last M - K columns of VT**T contain the deflated +*> right singular vectors. +*> \endverbatim +*> +*> \param[in] LDVT +*> \verbatim +*> LDVT is INTEGER +*> The leading dimension of the array VT. LDVT >= N. +*> \endverbatim +*> +*> \param[in,out] VT2 +*> \verbatim +*> VT2 is DOUBLE PRECISION array, dimension (LDVT2, N) +*> The first K columns of VT2**T contain the non-deflated +*> right singular vectors for the split problem. +*> \endverbatim +*> +*> \param[in] LDVT2 +*> \verbatim +*> LDVT2 is INTEGER +*> The leading dimension of the array VT2. LDVT2 >= N. +*> \endverbatim +*> +*> \param[in] IDXC +*> \verbatim +*> IDXC is INTEGER array, dimension ( N ) +*> The permutation used to arrange the columns of U (and rows of +*> VT) into three groups: the first group contains non-zero +*> entries only at and above (or before) NL +1; the second +*> contains non-zero entries only at and below (or after) NL+2; +*> and the third is dense. The first column of U and the row of +*> VT are treated separately, however. +*> +*> The rows of the singular vectors found by DLASD4 +*> must be likewise permuted before the matrix multiplies can +*> take place. +*> \endverbatim +*> +*> \param[in] CTOT +*> \verbatim +*> CTOT is INTEGER array, dimension ( 4 ) +*> A count of the total number of the various types of columns +*> in U (or rows in VT), as described in IDXC. The fourth column +*> type is any column which has been deflated. +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (K) +*> The first K elements of this array contain the components +*> of the deflation-adjusted updating row vector. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = 1, a singular value did not converge +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, + $ LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, + $ INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR, + $ SQRE +* .. +* .. Array Arguments .. + INTEGER CTOT( * ), IDXC( * ) + DOUBLE PRECISION D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ), + $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), + $ Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO, NEGONE + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, + $ NEGONE = -1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER CTEMP, I, J, JC, KTEMP, M, N, NLP1, NLP2, NRP1 + DOUBLE PRECISION RHO, TEMP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3, DNRM2 + EXTERNAL DLAMC3, DNRM2 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLACPY, DLASCL, DLASD4, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( NL.LT.1 ) THEN + INFO = -1 + ELSE IF( NR.LT.1 ) THEN + INFO = -2 + ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN + INFO = -3 + END IF +* + N = NL + NR + 1 + M = N + SQRE + NLP1 = NL + 1 + NLP2 = NL + 2 +* + IF( ( K.LT.1 ) .OR. ( K.GT.N ) ) THEN + INFO = -4 + ELSE IF( LDQ.LT.K ) THEN + INFO = -7 + ELSE IF( LDU.LT.N ) THEN + INFO = -10 + ELSE IF( LDU2.LT.N ) THEN + INFO = -12 + ELSE IF( LDVT.LT.M ) THEN + INFO = -14 + ELSE IF( LDVT2.LT.M ) THEN + INFO = -16 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( K.EQ.1 ) THEN + D( 1 ) = ABS( Z( 1 ) ) + CALL DCOPY( M, VT2( 1, 1 ), LDVT2, VT( 1, 1 ), LDVT ) + IF( Z( 1 ).GT.ZERO ) THEN + CALL DCOPY( N, U2( 1, 1 ), 1, U( 1, 1 ), 1 ) + ELSE + DO 10 I = 1, N + U( I, 1 ) = -U2( I, 1 ) + 10 CONTINUE + END IF + RETURN + END IF +* +* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can +* be computed with high relative accuracy (barring over/underflow). +* This is a problem on machines without a guard digit in +* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). +* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), +* which on any of these machines zeros out the bottommost +* bit of DSIGMA(I) if it is 1; this makes the subsequent +* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation +* occurs. On binary machines with a guard digit (almost all +* machines) it does not change DSIGMA(I) at all. On hexadecimal +* and decimal machines with a guard digit, it slightly +* changes the bottommost bits of DSIGMA(I). It does not account +* for hexadecimal or decimal machines without guard digits +* (we know of none). We use a subroutine call to compute +* 2*DSIGMA(I) to prevent optimizing compilers from eliminating +* this code. +* + DO 20 I = 1, K + DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I ) + 20 CONTINUE +* +* Keep a copy of Z. +* + CALL DCOPY( K, Z, 1, Q, 1 ) +* +* Normalize Z. +* + RHO = DNRM2( K, Z, 1 ) + CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO ) + RHO = RHO*RHO +* +* Find the new singular values. +* + DO 30 J = 1, K + CALL DLASD4( K, J, DSIGMA, Z, U( 1, J ), RHO, D( J ), + $ VT( 1, J ), INFO ) +* +* If the zero finder fails, report the convergence failure. +* + IF( INFO.NE.0 ) THEN + RETURN + END IF + 30 CONTINUE +* +* Compute updated Z. +* + DO 60 I = 1, K + Z( I ) = U( I, K )*VT( I, K ) + DO 40 J = 1, I - 1 + Z( I ) = Z( I )*( U( I, J )*VT( I, J ) / + $ ( DSIGMA( I )-DSIGMA( J ) ) / + $ ( DSIGMA( I )+DSIGMA( J ) ) ) + 40 CONTINUE + DO 50 J = I, K - 1 + Z( I ) = Z( I )*( U( I, J )*VT( I, J ) / + $ ( DSIGMA( I )-DSIGMA( J+1 ) ) / + $ ( DSIGMA( I )+DSIGMA( J+1 ) ) ) + 50 CONTINUE + Z( I ) = SIGN( SQRT( ABS( Z( I ) ) ), Q( I, 1 ) ) + 60 CONTINUE +* +* Compute left singular vectors of the modified diagonal matrix, +* and store related information for the right singular vectors. +* + DO 90 I = 1, K + VT( 1, I ) = Z( 1 ) / U( 1, I ) / VT( 1, I ) + U( 1, I ) = NEGONE + DO 70 J = 2, K + VT( J, I ) = Z( J ) / U( J, I ) / VT( J, I ) + U( J, I ) = DSIGMA( J )*VT( J, I ) + 70 CONTINUE + TEMP = DNRM2( K, U( 1, I ), 1 ) + Q( 1, I ) = U( 1, I ) / TEMP + DO 80 J = 2, K + JC = IDXC( J ) + Q( J, I ) = U( JC, I ) / TEMP + 80 CONTINUE + 90 CONTINUE +* +* Update the left singular vector matrix. +* + IF( K.EQ.2 ) THEN + CALL DGEMM( 'N', 'N', N, K, K, ONE, U2, LDU2, Q, LDQ, ZERO, U, + $ LDU ) + GO TO 100 + END IF + IF( CTOT( 1 ).GT.0 ) THEN + CALL DGEMM( 'N', 'N', NL, K, CTOT( 1 ), ONE, U2( 1, 2 ), LDU2, + $ Q( 2, 1 ), LDQ, ZERO, U( 1, 1 ), LDU ) + IF( CTOT( 3 ).GT.0 ) THEN + KTEMP = 2 + CTOT( 1 ) + CTOT( 2 ) + CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ), + $ LDU2, Q( KTEMP, 1 ), LDQ, ONE, U( 1, 1 ), LDU ) + END IF + ELSE IF( CTOT( 3 ).GT.0 ) THEN + KTEMP = 2 + CTOT( 1 ) + CTOT( 2 ) + CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ), + $ LDU2, Q( KTEMP, 1 ), LDQ, ZERO, U( 1, 1 ), LDU ) + ELSE + CALL DLACPY( 'F', NL, K, U2, LDU2, U, LDU ) + END IF + CALL DCOPY( K, Q( 1, 1 ), LDQ, U( NLP1, 1 ), LDU ) + KTEMP = 2 + CTOT( 1 ) + CTEMP = CTOT( 2 ) + CTOT( 3 ) + CALL DGEMM( 'N', 'N', NR, K, CTEMP, ONE, U2( NLP2, KTEMP ), LDU2, + $ Q( KTEMP, 1 ), LDQ, ZERO, U( NLP2, 1 ), LDU ) +* +* Generate the right singular vectors. +* + 100 CONTINUE + DO 120 I = 1, K + TEMP = DNRM2( K, VT( 1, I ), 1 ) + Q( I, 1 ) = VT( 1, I ) / TEMP + DO 110 J = 2, K + JC = IDXC( J ) + Q( I, J ) = VT( JC, I ) / TEMP + 110 CONTINUE + 120 CONTINUE +* +* Update the right singular vector matrix. +* + IF( K.EQ.2 ) THEN + CALL DGEMM( 'N', 'N', K, M, K, ONE, Q, LDQ, VT2, LDVT2, ZERO, + $ VT, LDVT ) + RETURN + END IF + KTEMP = 1 + CTOT( 1 ) + CALL DGEMM( 'N', 'N', K, NLP1, KTEMP, ONE, Q( 1, 1 ), LDQ, + $ VT2( 1, 1 ), LDVT2, ZERO, VT( 1, 1 ), LDVT ) + KTEMP = 2 + CTOT( 1 ) + CTOT( 2 ) + IF( KTEMP.LE.LDVT2 ) + $ CALL DGEMM( 'N', 'N', K, NLP1, CTOT( 3 ), ONE, Q( 1, KTEMP ), + $ LDQ, VT2( KTEMP, 1 ), LDVT2, ONE, VT( 1, 1 ), + $ LDVT ) +* + KTEMP = CTOT( 1 ) + 1 + NRP1 = NR + SQRE + IF( KTEMP.GT.1 ) THEN + DO 130 I = 1, K + Q( I, KTEMP ) = Q( I, 1 ) + 130 CONTINUE + DO 140 I = NLP2, M + VT2( KTEMP, I ) = VT2( 1, I ) + 140 CONTINUE + END IF + CTEMP = 1 + CTOT( 2 ) + CTOT( 3 ) + CALL DGEMM( 'N', 'N', K, NRP1, CTEMP, ONE, Q( 1, KTEMP ), LDQ, + $ VT2( KTEMP, NLP2 ), LDVT2, ZERO, VT( 1, NLP2 ), LDVT ) +* + RETURN +* +* End of DLASD3 +* + END diff --git a/math/lapack/src/main/fortran/dlasd4.f b/math/lapack/src/main/fortran/dlasd4.f new file mode 100644 index 0000000000..8b4a8762c8 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasd4.f @@ -0,0 +1,1061 @@ +*> \brief \b DLASD4 computes the square root of the i-th updated eigenvalue of a positive symmetric rank-one modification to a positive diagonal matrix. Used by dbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASD4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER I, INFO, N +* DOUBLE PRECISION RHO, SIGMA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), DELTA( * ), WORK( * ), Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This subroutine computes the square root of the I-th updated +*> eigenvalue of a positive symmetric rank-one modification to +*> a positive diagonal matrix whose entries are given as the squares +*> of the corresponding entries in the array d, and that +*> +*> 0 <= D(i) < D(j) for i < j +*> +*> and that RHO > 0. This is arranged by the calling routine, and is +*> no loss in generality. The rank-one modified system is thus +*> +*> diag( D ) * diag( D ) + RHO * Z * Z_transpose. +*> +*> where we assume the Euclidean norm of Z is 1. +*> +*> The method consists of approximating the rational functions in the +*> secular equation by simpler interpolating rational functions. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The length of all arrays. +*> \endverbatim +*> +*> \param[in] I +*> \verbatim +*> I is INTEGER +*> The index of the eigenvalue to be computed. 1 <= I <= N. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension ( N ) +*> The original eigenvalues. It is assumed that they are in +*> order, 0 <= D(I) < D(J) for I < J. +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( N ) +*> The components of the updating vector. +*> \endverbatim +*> +*> \param[out] DELTA +*> \verbatim +*> DELTA is DOUBLE PRECISION array, dimension ( N ) +*> If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th +*> component. If N = 1, then DELTA(1) = 1. The vector DELTA +*> contains the information necessary to construct the +*> (singular) eigenvectors. +*> \endverbatim +*> +*> \param[in] RHO +*> \verbatim +*> RHO is DOUBLE PRECISION +*> The scalar in the symmetric updating formula. +*> \endverbatim +*> +*> \param[out] SIGMA +*> \verbatim +*> SIGMA is DOUBLE PRECISION +*> The computed sigma_I, the I-th updated eigenvalue. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension ( N ) +*> If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th +*> component. If N = 1, then WORK( 1 ) = 1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> > 0: if INFO = 1, the updating process failed. +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> Logical variable ORGATI (origin-at-i?) is used for distinguishing +*> whether D(i) or D(i+1) is treated as the origin. +*> +*> ORGATI = .true. origin at i +*> ORGATI = .false. origin at i+1 +*> +*> Logical variable SWTCH3 (switch-for-3-poles?) is for noting +*> if we are working with THREE poles! +*> +*> MAXIT is the maximum number of iterations allowed for each +*> eigenvalue. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ren-Cang Li, Computer Science Division, University of California +*> at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER I, INFO, N + DOUBLE PRECISION RHO, SIGMA +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), DELTA( * ), WORK( * ), Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 400 ) + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ THREE = 3.0D+0, FOUR = 4.0D+0, EIGHT = 8.0D+0, + $ TEN = 10.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ORGATI, SWTCH, SWTCH3, GEOMAVG + INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER + DOUBLE PRECISION A, B, C, DELSQ, DELSQ2, SQ2, DPHI, DPSI, DTIIM, + $ DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS, + $ ERRETM, ETA, PHI, PREW, PSI, RHOINV, SGLB, + $ SGUB, TAU, TAU2, TEMP, TEMP1, TEMP2, W +* .. +* .. Local Arrays .. + DOUBLE PRECISION DD( 3 ), ZZ( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DLAED6, DLASD5 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Since this routine is called in an inner loop, we do no argument +* checking. +* +* Quick return for N=1 and 2. +* + INFO = 0 + IF( N.EQ.1 ) THEN +* +* Presumably, I=1 upon entry +* + SIGMA = SQRT( D( 1 )*D( 1 )+RHO*Z( 1 )*Z( 1 ) ) + DELTA( 1 ) = ONE + WORK( 1 ) = ONE + RETURN + END IF + IF( N.EQ.2 ) THEN + CALL DLASD5( I, D, Z, DELTA, RHO, SIGMA, WORK ) + RETURN + END IF +* +* Compute machine epsilon +* + EPS = DLAMCH( 'Epsilon' ) + RHOINV = ONE / RHO + TAU2= ZERO +* +* The case I = N +* + IF( I.EQ.N ) THEN +* +* Initialize some basic variables +* + II = N - 1 + NITER = 1 +* +* Calculate initial guess +* + TEMP = RHO / TWO +* +* If ||Z||_2 is not one, then TEMP should be set to +* RHO * ||Z||_2^2 / TWO +* + TEMP1 = TEMP / ( D( N )+SQRT( D( N )*D( N )+TEMP ) ) + DO 10 J = 1, N + WORK( J ) = D( J ) + D( N ) + TEMP1 + DELTA( J ) = ( D( J )-D( N ) ) - TEMP1 + 10 CONTINUE +* + PSI = ZERO + DO 20 J = 1, N - 2 + PSI = PSI + Z( J )*Z( J ) / ( DELTA( J )*WORK( J ) ) + 20 CONTINUE +* + C = RHOINV + PSI + W = C + Z( II )*Z( II ) / ( DELTA( II )*WORK( II ) ) + + $ Z( N )*Z( N ) / ( DELTA( N )*WORK( N ) ) +* + IF( W.LE.ZERO ) THEN + TEMP1 = SQRT( D( N )*D( N )+RHO ) + TEMP = Z( N-1 )*Z( N-1 ) / ( ( D( N-1 )+TEMP1 )* + $ ( D( N )-D( N-1 )+RHO / ( D( N )+TEMP1 ) ) ) + + $ Z( N )*Z( N ) / RHO +* +* The following TAU2 is to approximate +* SIGMA_n^2 - D( N )*D( N ) +* + IF( C.LE.TEMP ) THEN + TAU = RHO + ELSE + DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) ) + A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) + B = Z( N )*Z( N )*DELSQ + IF( A.LT.ZERO ) THEN + TAU2 = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) + ELSE + TAU2 = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) + END IF + TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) ) + END IF +* +* It can be proved that +* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU2 <= D(N)^2+RHO +* + ELSE + DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) ) + A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) + B = Z( N )*Z( N )*DELSQ +* +* The following TAU2 is to approximate +* SIGMA_n^2 - D( N )*D( N ) +* + IF( A.LT.ZERO ) THEN + TAU2 = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) + ELSE + TAU2 = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) + END IF + TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) ) + +* +* It can be proved that +* D(N)^2 < D(N)^2+TAU2 < SIGMA(N)^2 < D(N)^2+RHO/2 +* + END IF +* +* The following TAU is to approximate SIGMA_n - D( N ) +* +* TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) ) +* + SIGMA = D( N ) + TAU + DO 30 J = 1, N + DELTA( J ) = ( D( J )-D( N ) ) - TAU + WORK( J ) = D( J ) + D( N ) + TAU + 30 CONTINUE +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 40 J = 1, II + TEMP = Z( J ) / ( DELTA( J )*WORK( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 40 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + TEMP = Z( N ) / ( DELTA( N )*WORK( N ) ) + PHI = Z( N )*TEMP + DPHI = TEMP*TEMP + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +* $ + ABS( TAU2 )*( DPSI+DPHI ) +* + W = RHOINV + PHI + PSI +* +* Test for convergence +* + IF( ABS( W ).LE.EPS*ERRETM ) THEN + GO TO 240 + END IF +* +* Calculate the new step +* + NITER = NITER + 1 + DTNSQ1 = WORK( N-1 )*DELTA( N-1 ) + DTNSQ = WORK( N )*DELTA( N ) + C = W - DTNSQ1*DPSI - DTNSQ*DPHI + A = ( DTNSQ+DTNSQ1 )*W - DTNSQ*DTNSQ1*( DPSI+DPHI ) + B = DTNSQ*DTNSQ1*W + IF( C.LT.ZERO ) + $ C = ABS( C ) + IF( C.EQ.ZERO ) THEN + ETA = RHO - SIGMA*SIGMA + ELSE IF( A.GE.ZERO ) THEN + ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF +* +* Note, eta should be positive if w is negative, and +* eta should be negative otherwise. However, +* if for some reason caused by roundoff, eta*w > 0, +* we simply use one Newton step instead. This way +* will guarantee eta*w < 0. +* + IF( W*ETA.GT.ZERO ) + $ ETA = -W / ( DPSI+DPHI ) + TEMP = ETA - DTNSQ + IF( TEMP.GT.RHO ) + $ ETA = RHO + DTNSQ +* + ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) ) + TAU = TAU + ETA + SIGMA = SIGMA + ETA +* + DO 50 J = 1, N + DELTA( J ) = DELTA( J ) - ETA + WORK( J ) = WORK( J ) + ETA + 50 CONTINUE +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 60 J = 1, II + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 60 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + TAU2 = WORK( N )*DELTA( N ) + TEMP = Z( N ) / TAU2 + PHI = Z( N )*TEMP + DPHI = TEMP*TEMP + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +* $ + ABS( TAU2 )*( DPSI+DPHI ) +* + W = RHOINV + PHI + PSI +* +* Main loop to update the values of the array DELTA +* + ITER = NITER + 1 +* + DO 90 NITER = ITER, MAXIT +* +* Test for convergence +* + IF( ABS( W ).LE.EPS*ERRETM ) THEN + GO TO 240 + END IF +* +* Calculate the new step +* + DTNSQ1 = WORK( N-1 )*DELTA( N-1 ) + DTNSQ = WORK( N )*DELTA( N ) + C = W - DTNSQ1*DPSI - DTNSQ*DPHI + A = ( DTNSQ+DTNSQ1 )*W - DTNSQ1*DTNSQ*( DPSI+DPHI ) + B = DTNSQ1*DTNSQ*W + IF( A.GE.ZERO ) THEN + ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF +* +* Note, eta should be positive if w is negative, and +* eta should be negative otherwise. However, +* if for some reason caused by roundoff, eta*w > 0, +* we simply use one Newton step instead. This way +* will guarantee eta*w < 0. +* + IF( W*ETA.GT.ZERO ) + $ ETA = -W / ( DPSI+DPHI ) + TEMP = ETA - DTNSQ + IF( TEMP.LE.ZERO ) + $ ETA = ETA / TWO +* + ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) ) + TAU = TAU + ETA + SIGMA = SIGMA + ETA +* + DO 70 J = 1, N + DELTA( J ) = DELTA( J ) - ETA + WORK( J ) = WORK( J ) + ETA + 70 CONTINUE +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 80 J = 1, II + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 80 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + TAU2 = WORK( N )*DELTA( N ) + TEMP = Z( N ) / TAU2 + PHI = Z( N )*TEMP + DPHI = TEMP*TEMP + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +* $ + ABS( TAU2 )*( DPSI+DPHI ) +* + W = RHOINV + PHI + PSI + 90 CONTINUE +* +* Return with INFO = 1, NITER = MAXIT and not converged +* + INFO = 1 + GO TO 240 +* +* End for the case I = N +* + ELSE +* +* The case for I < N +* + NITER = 1 + IP1 = I + 1 +* +* Calculate initial guess +* + DELSQ = ( D( IP1 )-D( I ) )*( D( IP1 )+D( I ) ) + DELSQ2 = DELSQ / TWO + SQ2=SQRT( ( D( I )*D( I )+D( IP1 )*D( IP1 ) ) / TWO ) + TEMP = DELSQ2 / ( D( I )+SQ2 ) + DO 100 J = 1, N + WORK( J ) = D( J ) + D( I ) + TEMP + DELTA( J ) = ( D( J )-D( I ) ) - TEMP + 100 CONTINUE +* + PSI = ZERO + DO 110 J = 1, I - 1 + PSI = PSI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) ) + 110 CONTINUE +* + PHI = ZERO + DO 120 J = N, I + 2, -1 + PHI = PHI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) ) + 120 CONTINUE + C = RHOINV + PSI + PHI + W = C + Z( I )*Z( I ) / ( WORK( I )*DELTA( I ) ) + + $ Z( IP1 )*Z( IP1 ) / ( WORK( IP1 )*DELTA( IP1 ) ) +* + GEOMAVG = .FALSE. + IF( W.GT.ZERO ) THEN +* +* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2 +* +* We choose d(i) as origin. +* + ORGATI = .TRUE. + II = I + SGLB = ZERO + SGUB = DELSQ2 / ( D( I )+SQ2 ) + A = C*DELSQ + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 ) + B = Z( I )*Z( I )*DELSQ + IF( A.GT.ZERO ) THEN + TAU2 = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + ELSE + TAU2 = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + END IF +* +* TAU2 now is an estimation of SIGMA^2 - D( I )^2. The +* following, however, is the corresponding estimation of +* SIGMA - D( I ). +* + TAU = TAU2 / ( D( I )+SQRT( D( I )*D( I )+TAU2 ) ) + TEMP = SQRT(EPS) + IF( (D(I).LE.TEMP*D(IP1)).AND.(ABS(Z(I)).LE.TEMP) + $ .AND.(D(I).GT.ZERO) ) THEN + TAU = MIN( TEN*D(I), SGUB ) + GEOMAVG = .TRUE. + END IF + ELSE +* +* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2 +* +* We choose d(i+1) as origin. +* + ORGATI = .FALSE. + II = IP1 + SGLB = -DELSQ2 / ( D( II )+SQ2 ) + SGUB = ZERO + A = C*DELSQ - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 ) + B = Z( IP1 )*Z( IP1 )*DELSQ + IF( A.LT.ZERO ) THEN + TAU2 = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) ) + ELSE + TAU2 = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C ) + END IF +* +* TAU2 now is an estimation of SIGMA^2 - D( IP1 )^2. The +* following, however, is the corresponding estimation of +* SIGMA - D( IP1 ). +* + TAU = TAU2 / ( D( IP1 )+SQRT( ABS( D( IP1 )*D( IP1 )+ + $ TAU2 ) ) ) + END IF +* + SIGMA = D( II ) + TAU + DO 130 J = 1, N + WORK( J ) = D( J ) + D( II ) + TAU + DELTA( J ) = ( D( J )-D( II ) ) - TAU + 130 CONTINUE + IIM1 = II - 1 + IIP1 = II + 1 +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 150 J = 1, IIM1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 150 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + DPHI = ZERO + PHI = ZERO + DO 160 J = N, IIP1, -1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PHI = PHI + Z( J )*TEMP + DPHI = DPHI + TEMP*TEMP + ERRETM = ERRETM + PHI + 160 CONTINUE +* + W = RHOINV + PHI + PSI +* +* W is the value of the secular function with +* its ii-th element removed. +* + SWTCH3 = .FALSE. + IF( ORGATI ) THEN + IF( W.LT.ZERO ) + $ SWTCH3 = .TRUE. + ELSE + IF( W.GT.ZERO ) + $ SWTCH3 = .TRUE. + END IF + IF( II.EQ.1 .OR. II.EQ.N ) + $ SWTCH3 = .FALSE. +* + TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) + DW = DPSI + DPHI + TEMP*TEMP + TEMP = Z( II )*TEMP + W = W + TEMP + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + $ + THREE*ABS( TEMP ) +* $ + ABS( TAU2 )*DW +* +* Test for convergence +* + IF( ABS( W ).LE.EPS*ERRETM ) THEN + GO TO 240 + END IF +* + IF( W.LE.ZERO ) THEN + SGLB = MAX( SGLB, TAU ) + ELSE + SGUB = MIN( SGUB, TAU ) + END IF +* +* Calculate the new step +* + NITER = NITER + 1 + IF( .NOT.SWTCH3 ) THEN + DTIPSQ = WORK( IP1 )*DELTA( IP1 ) + DTISQ = WORK( I )*DELTA( I ) + IF( ORGATI ) THEN + C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2 + ELSE + C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2 + END IF + A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW + B = DTIPSQ*DTISQ*W + IF( C.EQ.ZERO ) THEN + IF( A.EQ.ZERO ) THEN + IF( ORGATI ) THEN + A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI ) + ELSE + A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI ) + END IF + END IF + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + ELSE +* +* Interpolation using THREE most relevant poles +* + DTIIM = WORK( IIM1 )*DELTA( IIM1 ) + DTIIP = WORK( IIP1 )*DELTA( IIP1 ) + TEMP = RHOINV + PSI + PHI + IF( ORGATI ) THEN + TEMP1 = Z( IIM1 ) / DTIIM + TEMP1 = TEMP1*TEMP1 + C = ( TEMP - DTIIP*( DPSI+DPHI ) ) - + $ ( D( IIM1 )-D( IIP1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1 + ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) + IF( DPSI.LT.TEMP1 ) THEN + ZZ( 3 ) = DTIIP*DTIIP*DPHI + ELSE + ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI ) + END IF + ELSE + TEMP1 = Z( IIP1 ) / DTIIP + TEMP1 = TEMP1*TEMP1 + C = ( TEMP - DTIIM*( DPSI+DPHI ) ) - + $ ( D( IIP1 )-D( IIM1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1 + IF( DPHI.LT.TEMP1 ) THEN + ZZ( 1 ) = DTIIM*DTIIM*DPSI + ELSE + ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) ) + END IF + ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) + END IF + ZZ( 2 ) = Z( II )*Z( II ) + DD( 1 ) = DTIIM + DD( 2 ) = DELTA( II )*WORK( II ) + DD( 3 ) = DTIIP + CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO ) +* + IF( INFO.NE.0 ) THEN +* +* If INFO is not 0, i.e., DLAED6 failed, switch back +* to 2 pole interpolation. +* + SWTCH3 = .FALSE. + INFO = 0 + DTIPSQ = WORK( IP1 )*DELTA( IP1 ) + DTISQ = WORK( I )*DELTA( I ) + IF( ORGATI ) THEN + C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2 + ELSE + C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2 + END IF + A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW + B = DTIPSQ*DTISQ*W + IF( C.EQ.ZERO ) THEN + IF( A.EQ.ZERO ) THEN + IF( ORGATI ) THEN + A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI ) + ELSE + A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI) + END IF + END IF + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + END IF + END IF +* +* Note, eta should be positive if w is negative, and +* eta should be negative otherwise. However, +* if for some reason caused by roundoff, eta*w > 0, +* we simply use one Newton step instead. This way +* will guarantee eta*w < 0. +* + IF( W*ETA.GE.ZERO ) + $ ETA = -W / DW +* + ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) ) + TEMP = TAU + ETA + IF( TEMP.GT.SGUB .OR. TEMP.LT.SGLB ) THEN + IF( W.LT.ZERO ) THEN + ETA = ( SGUB-TAU ) / TWO + ELSE + ETA = ( SGLB-TAU ) / TWO + END IF + IF( GEOMAVG ) THEN + IF( W .LT. ZERO ) THEN + IF( TAU .GT. ZERO ) THEN + ETA = SQRT(SGUB*TAU)-TAU + END IF + ELSE + IF( SGLB .GT. ZERO ) THEN + ETA = SQRT(SGLB*TAU)-TAU + END IF + END IF + END IF + END IF +* + PREW = W +* + TAU = TAU + ETA + SIGMA = SIGMA + ETA +* + DO 170 J = 1, N + WORK( J ) = WORK( J ) + ETA + DELTA( J ) = DELTA( J ) - ETA + 170 CONTINUE +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 180 J = 1, IIM1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 180 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + DPHI = ZERO + PHI = ZERO + DO 190 J = N, IIP1, -1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PHI = PHI + Z( J )*TEMP + DPHI = DPHI + TEMP*TEMP + ERRETM = ERRETM + PHI + 190 CONTINUE +* + TAU2 = WORK( II )*DELTA( II ) + TEMP = Z( II ) / TAU2 + DW = DPSI + DPHI + TEMP*TEMP + TEMP = Z( II )*TEMP + W = RHOINV + PHI + PSI + TEMP + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + $ + THREE*ABS( TEMP ) +* $ + ABS( TAU2 )*DW +* + SWTCH = .FALSE. + IF( ORGATI ) THEN + IF( -W.GT.ABS( PREW ) / TEN ) + $ SWTCH = .TRUE. + ELSE + IF( W.GT.ABS( PREW ) / TEN ) + $ SWTCH = .TRUE. + END IF +* +* Main loop to update the values of the array DELTA and WORK +* + ITER = NITER + 1 +* + DO 230 NITER = ITER, MAXIT +* +* Test for convergence +* + IF( ABS( W ).LE.EPS*ERRETM ) THEN +* $ .OR. (SGUB-SGLB).LE.EIGHT*ABS(SGUB+SGLB) ) THEN + GO TO 240 + END IF +* + IF( W.LE.ZERO ) THEN + SGLB = MAX( SGLB, TAU ) + ELSE + SGUB = MIN( SGUB, TAU ) + END IF +* +* Calculate the new step +* + IF( .NOT.SWTCH3 ) THEN + DTIPSQ = WORK( IP1 )*DELTA( IP1 ) + DTISQ = WORK( I )*DELTA( I ) + IF( .NOT.SWTCH ) THEN + IF( ORGATI ) THEN + C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2 + ELSE + C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2 + END IF + ELSE + TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) + IF( ORGATI ) THEN + DPSI = DPSI + TEMP*TEMP + ELSE + DPHI = DPHI + TEMP*TEMP + END IF + C = W - DTISQ*DPSI - DTIPSQ*DPHI + END IF + A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW + B = DTIPSQ*DTISQ*W + IF( C.EQ.ZERO ) THEN + IF( A.EQ.ZERO ) THEN + IF( .NOT.SWTCH ) THEN + IF( ORGATI ) THEN + A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ* + $ ( DPSI+DPHI ) + ELSE + A = Z( IP1 )*Z( IP1 ) + + $ DTISQ*DTISQ*( DPSI+DPHI ) + END IF + ELSE + A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI + END IF + END IF + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + ELSE +* +* Interpolation using THREE most relevant poles +* + DTIIM = WORK( IIM1 )*DELTA( IIM1 ) + DTIIP = WORK( IIP1 )*DELTA( IIP1 ) + TEMP = RHOINV + PSI + PHI + IF( SWTCH ) THEN + C = TEMP - DTIIM*DPSI - DTIIP*DPHI + ZZ( 1 ) = DTIIM*DTIIM*DPSI + ZZ( 3 ) = DTIIP*DTIIP*DPHI + ELSE + IF( ORGATI ) THEN + TEMP1 = Z( IIM1 ) / DTIIM + TEMP1 = TEMP1*TEMP1 + TEMP2 = ( D( IIM1 )-D( IIP1 ) )* + $ ( D( IIM1 )+D( IIP1 ) )*TEMP1 + C = TEMP - DTIIP*( DPSI+DPHI ) - TEMP2 + ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) + IF( DPSI.LT.TEMP1 ) THEN + ZZ( 3 ) = DTIIP*DTIIP*DPHI + ELSE + ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI ) + END IF + ELSE + TEMP1 = Z( IIP1 ) / DTIIP + TEMP1 = TEMP1*TEMP1 + TEMP2 = ( D( IIP1 )-D( IIM1 ) )* + $ ( D( IIM1 )+D( IIP1 ) )*TEMP1 + C = TEMP - DTIIM*( DPSI+DPHI ) - TEMP2 + IF( DPHI.LT.TEMP1 ) THEN + ZZ( 1 ) = DTIIM*DTIIM*DPSI + ELSE + ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) ) + END IF + ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) + END IF + END IF + DD( 1 ) = DTIIM + DD( 2 ) = DELTA( II )*WORK( II ) + DD( 3 ) = DTIIP + CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO ) +* + IF( INFO.NE.0 ) THEN +* +* If INFO is not 0, i.e., DLAED6 failed, switch +* back to two pole interpolation +* + SWTCH3 = .FALSE. + INFO = 0 + DTIPSQ = WORK( IP1 )*DELTA( IP1 ) + DTISQ = WORK( I )*DELTA( I ) + IF( .NOT.SWTCH ) THEN + IF( ORGATI ) THEN + C = W - DTIPSQ*DW + DELSQ*( Z( I )/DTISQ )**2 + ELSE + C = W - DTISQ*DW - DELSQ*( Z( IP1 )/DTIPSQ )**2 + END IF + ELSE + TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) + IF( ORGATI ) THEN + DPSI = DPSI + TEMP*TEMP + ELSE + DPHI = DPHI + TEMP*TEMP + END IF + C = W - DTISQ*DPSI - DTIPSQ*DPHI + END IF + A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW + B = DTIPSQ*DTISQ*W + IF( C.EQ.ZERO ) THEN + IF( A.EQ.ZERO ) THEN + IF( .NOT.SWTCH ) THEN + IF( ORGATI ) THEN + A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ* + $ ( DPSI+DPHI ) + ELSE + A = Z( IP1 )*Z( IP1 ) + + $ DTISQ*DTISQ*( DPSI+DPHI ) + END IF + ELSE + A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI + END IF + END IF + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + END IF + END IF +* +* Note, eta should be positive if w is negative, and +* eta should be negative otherwise. However, +* if for some reason caused by roundoff, eta*w > 0, +* we simply use one Newton step instead. This way +* will guarantee eta*w < 0. +* + IF( W*ETA.GE.ZERO ) + $ ETA = -W / DW +* + ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) ) + TEMP=TAU+ETA + IF( TEMP.GT.SGUB .OR. TEMP.LT.SGLB ) THEN + IF( W.LT.ZERO ) THEN + ETA = ( SGUB-TAU ) / TWO + ELSE + ETA = ( SGLB-TAU ) / TWO + END IF + IF( GEOMAVG ) THEN + IF( W .LT. ZERO ) THEN + IF( TAU .GT. ZERO ) THEN + ETA = SQRT(SGUB*TAU)-TAU + END IF + ELSE + IF( SGLB .GT. ZERO ) THEN + ETA = SQRT(SGLB*TAU)-TAU + END IF + END IF + END IF + END IF +* + PREW = W +* + TAU = TAU + ETA + SIGMA = SIGMA + ETA +* + DO 200 J = 1, N + WORK( J ) = WORK( J ) + ETA + DELTA( J ) = DELTA( J ) - ETA + 200 CONTINUE +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 210 J = 1, IIM1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 210 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + DPHI = ZERO + PHI = ZERO + DO 220 J = N, IIP1, -1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PHI = PHI + Z( J )*TEMP + DPHI = DPHI + TEMP*TEMP + ERRETM = ERRETM + PHI + 220 CONTINUE +* + TAU2 = WORK( II )*DELTA( II ) + TEMP = Z( II ) / TAU2 + DW = DPSI + DPHI + TEMP*TEMP + TEMP = Z( II )*TEMP + W = RHOINV + PHI + PSI + TEMP + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + $ + THREE*ABS( TEMP ) +* $ + ABS( TAU2 )*DW +* + IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) + $ SWTCH = .NOT.SWTCH +* + 230 CONTINUE +* +* Return with INFO = 1, NITER = MAXIT and not converged +* + INFO = 1 +* + END IF +* + 240 CONTINUE + RETURN +* +* End of DLASD4 +* + END diff --git a/math/lapack/src/main/fortran/dlasd5.f b/math/lapack/src/main/fortran/dlasd5.f new file mode 100644 index 0000000000..4896ba6b97 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasd5.f @@ -0,0 +1,231 @@ +*> \brief \b DLASD5 computes the square root of the i-th eigenvalue of a positive symmetric rank-one modification of a 2-by-2 diagonal matrix. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASD5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) +* +* .. Scalar Arguments .. +* INTEGER I +* DOUBLE PRECISION DSIGMA, RHO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This subroutine computes the square root of the I-th eigenvalue +*> of a positive symmetric rank-one modification of a 2-by-2 diagonal +*> matrix +*> +*> diag( D ) * diag( D ) + RHO * Z * transpose(Z) . +*> +*> The diagonal entries in the array D are assumed to satisfy +*> +*> 0 <= D(i) < D(j) for i < j . +*> +*> We also assume RHO > 0 and that the Euclidean norm of the vector +*> Z is one. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] I +*> \verbatim +*> I is INTEGER +*> The index of the eigenvalue to be computed. I = 1 or I = 2. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension ( 2 ) +*> The original eigenvalues. We assume 0 <= D(1) < D(2). +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( 2 ) +*> The components of the updating vector. +*> \endverbatim +*> +*> \param[out] DELTA +*> \verbatim +*> DELTA is DOUBLE PRECISION array, dimension ( 2 ) +*> Contains (D(j) - sigma_I) in its j-th component. +*> The vector DELTA contains the information necessary +*> to construct the eigenvectors. +*> \endverbatim +*> +*> \param[in] RHO +*> \verbatim +*> RHO is DOUBLE PRECISION +*> The scalar in the symmetric updating formula. +*> \endverbatim +*> +*> \param[out] DSIGMA +*> \verbatim +*> DSIGMA is DOUBLE PRECISION +*> The computed sigma_I, the I-th updated eigenvalue. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension ( 2 ) +*> WORK contains (D(j) + sigma_I) in its j-th component. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ren-Cang Li, Computer Science Division, University of California +*> at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER I + DOUBLE PRECISION DSIGMA, RHO +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ THREE = 3.0D+0, FOUR = 4.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION B, C, DEL, DELSQ, TAU, W +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* + DEL = D( 2 ) - D( 1 ) + DELSQ = DEL*( D( 2 )+D( 1 ) ) + IF( I.EQ.1 ) THEN + W = ONE + FOUR*RHO*( Z( 2 )*Z( 2 ) / ( D( 1 )+THREE*D( 2 ) )- + $ Z( 1 )*Z( 1 ) / ( THREE*D( 1 )+D( 2 ) ) ) / DEL + IF( W.GT.ZERO ) THEN + B = DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) + C = RHO*Z( 1 )*Z( 1 )*DELSQ +* +* B > ZERO, always +* +* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) +* + TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) ) +* +* The following TAU is DSIGMA - D( 1 ) +* + TAU = TAU / ( D( 1 )+SQRT( D( 1 )*D( 1 )+TAU ) ) + DSIGMA = D( 1 ) + TAU + DELTA( 1 ) = -TAU + DELTA( 2 ) = DEL - TAU + WORK( 1 ) = TWO*D( 1 ) + TAU + WORK( 2 ) = ( D( 1 )+TAU ) + D( 2 ) +* DELTA( 1 ) = -Z( 1 ) / TAU +* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) + ELSE + B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) + C = RHO*Z( 2 )*Z( 2 )*DELSQ +* +* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) +* + IF( B.GT.ZERO ) THEN + TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) ) + ELSE + TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO + END IF +* +* The following TAU is DSIGMA - D( 2 ) +* + TAU = TAU / ( D( 2 )+SQRT( ABS( D( 2 )*D( 2 )+TAU ) ) ) + DSIGMA = D( 2 ) + TAU + DELTA( 1 ) = -( DEL+TAU ) + DELTA( 2 ) = -TAU + WORK( 1 ) = D( 1 ) + TAU + D( 2 ) + WORK( 2 ) = TWO*D( 2 ) + TAU +* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) +* DELTA( 2 ) = -Z( 2 ) / TAU + END IF +* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) +* DELTA( 1 ) = DELTA( 1 ) / TEMP +* DELTA( 2 ) = DELTA( 2 ) / TEMP + ELSE +* +* Now I=2 +* + B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) + C = RHO*Z( 2 )*Z( 2 )*DELSQ +* +* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) +* + IF( B.GT.ZERO ) THEN + TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO + ELSE + TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) ) + END IF +* +* The following TAU is DSIGMA - D( 2 ) +* + TAU = TAU / ( D( 2 )+SQRT( D( 2 )*D( 2 )+TAU ) ) + DSIGMA = D( 2 ) + TAU + DELTA( 1 ) = -( DEL+TAU ) + DELTA( 2 ) = -TAU + WORK( 1 ) = D( 1 ) + TAU + D( 2 ) + WORK( 2 ) = TWO*D( 2 ) + TAU +* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) +* DELTA( 2 ) = -Z( 2 ) / TAU +* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) +* DELTA( 1 ) = DELTA( 1 ) / TEMP +* DELTA( 2 ) = DELTA( 2 ) / TEMP + END IF + RETURN +* +* End of DLASD5 +* + END diff --git a/math/lapack/src/main/fortran/dlasd6.f b/math/lapack/src/main/fortran/dlasd6.f new file mode 100644 index 0000000000..5cab78a070 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasd6.f @@ -0,0 +1,443 @@ +*> \brief \b DLASD6 computes the SVD of an updated upper bidiagonal matrix obtained by merging two smaller ones by appending a row. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASD6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, +* IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, +* LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, +* IWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, +* $ NR, SQRE +* DOUBLE PRECISION ALPHA, BETA, C, S +* .. +* .. Array Arguments .. +* INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ), +* $ PERM( * ) +* DOUBLE PRECISION D( * ), DIFL( * ), DIFR( * ), +* $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), +* $ VF( * ), VL( * ), WORK( * ), Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASD6 computes the SVD of an updated upper bidiagonal matrix B +*> obtained by merging two smaller ones by appending a row. This +*> routine is used only for the problem which requires all singular +*> values and optionally singular vector matrices in factored form. +*> B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE. +*> A related subroutine, DLASD1, handles the case in which all singular +*> values and singular vectors of the bidiagonal matrix are desired. +*> +*> DLASD6 computes the SVD as follows: +*> +*> ( D1(in) 0 0 0 ) +*> B = U(in) * ( Z1**T a Z2**T b ) * VT(in) +*> ( 0 0 D2(in) 0 ) +*> +*> = U(out) * ( D(out) 0) * VT(out) +*> +*> where Z**T = (Z1**T a Z2**T b) = u**T VT**T, and u is a vector of dimension M +*> with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros +*> elsewhere; and the entry b is empty if SQRE = 0. +*> +*> The singular values of B can be computed using D1, D2, the first +*> components of all the right singular vectors of the lower block, and +*> the last components of all the right singular vectors of the upper +*> block. These components are stored and updated in VF and VL, +*> respectively, in DLASD6. Hence U and VT are not explicitly +*> referenced. +*> +*> The singular values are stored in D. The algorithm consists of two +*> stages: +*> +*> The first stage consists of deflating the size of the problem +*> when there are multiple singular values or if there is a zero +*> in the Z vector. For each such occurrence the dimension of the +*> secular equation problem is reduced by one. This stage is +*> performed by the routine DLASD7. +*> +*> The second stage consists of calculating the updated +*> singular values. This is done by finding the roots of the +*> secular equation via the routine DLASD4 (as called by DLASD8). +*> This routine also updates VF and VL and computes the distances +*> between the updated singular values and the old singular +*> values. +*> +*> DLASD6 is called from DLASDA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ICOMPQ +*> \verbatim +*> ICOMPQ is INTEGER +*> Specifies whether singular vectors are to be computed in +*> factored form: +*> = 0: Compute singular values only. +*> = 1: Compute singular vectors in factored form as well. +*> \endverbatim +*> +*> \param[in] NL +*> \verbatim +*> NL is INTEGER +*> The row dimension of the upper block. NL >= 1. +*> \endverbatim +*> +*> \param[in] NR +*> \verbatim +*> NR is INTEGER +*> The row dimension of the lower block. NR >= 1. +*> \endverbatim +*> +*> \param[in] SQRE +*> \verbatim +*> SQRE is INTEGER +*> = 0: the lower block is an NR-by-NR square matrix. +*> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. +*> +*> The bidiagonal matrix has row dimension N = NL + NR + 1, +*> and column dimension M = N + SQRE. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension ( NL+NR+1 ). +*> On entry D(1:NL,1:NL) contains the singular values of the +*> upper block, and D(NL+2:N) contains the singular values +*> of the lower block. On exit D(1:N) contains the singular +*> values of the modified matrix. +*> \endverbatim +*> +*> \param[in,out] VF +*> \verbatim +*> VF is DOUBLE PRECISION array, dimension ( M ) +*> On entry, VF(1:NL+1) contains the first components of all +*> right singular vectors of the upper block; and VF(NL+2:M) +*> contains the first components of all right singular vectors +*> of the lower block. On exit, VF contains the first components +*> of all right singular vectors of the bidiagonal matrix. +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is DOUBLE PRECISION array, dimension ( M ) +*> On entry, VL(1:NL+1) contains the last components of all +*> right singular vectors of the upper block; and VL(NL+2:M) +*> contains the last components of all right singular vectors of +*> the lower block. On exit, VL contains the last components of +*> all right singular vectors of the bidiagonal matrix. +*> \endverbatim +*> +*> \param[in,out] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> Contains the diagonal element associated with the added row. +*> \endverbatim +*> +*> \param[in,out] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION +*> Contains the off-diagonal element associated with the added +*> row. +*> \endverbatim +*> +*> \param[in,out] IDXQ +*> \verbatim +*> IDXQ is INTEGER array, dimension ( N ) +*> This contains the permutation which will reintegrate the +*> subproblem just solved back into sorted order, i.e. +*> D( IDXQ( I = 1, N ) ) will be in ascending order. +*> \endverbatim +*> +*> \param[out] PERM +*> \verbatim +*> PERM is INTEGER array, dimension ( N ) +*> The permutations (from deflation and sorting) to be applied +*> to each block. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[out] GIVPTR +*> \verbatim +*> GIVPTR is INTEGER +*> The number of Givens rotations which took place in this +*> subproblem. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[out] GIVCOL +*> \verbatim +*> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) +*> Each pair of numbers indicates a pair of columns to take place +*> in a Givens rotation. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[in] LDGCOL +*> \verbatim +*> LDGCOL is INTEGER +*> leading dimension of GIVCOL, must be at least N. +*> \endverbatim +*> +*> \param[out] GIVNUM +*> \verbatim +*> GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) +*> Each number indicates the C or S value to be used in the +*> corresponding Givens rotation. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[in] LDGNUM +*> \verbatim +*> LDGNUM is INTEGER +*> The leading dimension of GIVNUM and POLES, must be at least N. +*> \endverbatim +*> +*> \param[out] POLES +*> \verbatim +*> POLES is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) +*> On exit, POLES(1,*) is an array containing the new singular +*> values obtained from solving the secular equation, and +*> POLES(2,*) is an array containing the poles in the secular +*> equation. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[out] DIFL +*> \verbatim +*> DIFL is DOUBLE PRECISION array, dimension ( N ) +*> On exit, DIFL(I) is the distance between I-th updated +*> (undeflated) singular value and the I-th (undeflated) old +*> singular value. +*> \endverbatim +*> +*> \param[out] DIFR +*> \verbatim +*> DIFR is DOUBLE PRECISION array, +*> dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and +*> dimension ( K ) if ICOMPQ = 0. +*> On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not +*> defined and will not be referenced. +*> +*> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the +*> normalizing factors for the right singular vector matrix. +*> +*> See DLASD8 for details on DIFL and DIFR. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( M ) +*> The first elements of this array contain the components +*> of the deflation-adjusted updating row vector. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Contains the dimension of the non-deflated matrix, +*> This is the order of the related secular equation. 1 <= K <=N. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION +*> C contains garbage if SQRE =0 and the C-value of a Givens +*> rotation related to the right null space if SQRE = 1. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION +*> S contains garbage if SQRE =0 and the S-value of a Givens +*> rotation related to the right null space if SQRE = 1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension ( 4 * M ) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension ( 3 * N ) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = 1, a singular value did not converge +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, + $ IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, + $ LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, + $ IWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, + $ NR, SQRE + DOUBLE PRECISION ALPHA, BETA, C, S +* .. +* .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ), + $ PERM( * ) + DOUBLE PRECISION D( * ), DIFL( * ), DIFR( * ), + $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), + $ VF( * ), VL( * ), WORK( * ), Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M, + $ N, N1, N2 + DOUBLE PRECISION ORGNRM +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLAMRG, DLASCL, DLASD7, DLASD8, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + N = NL + NR + 1 + M = N + SQRE +* + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( NL.LT.1 ) THEN + INFO = -2 + ELSE IF( NR.LT.1 ) THEN + INFO = -3 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -4 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -14 + ELSE IF( LDGNUM.LT.N ) THEN + INFO = -16 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD6', -INFO ) + RETURN + END IF +* +* The following values are for bookkeeping purposes only. They are +* integer pointers which indicate the portion of the workspace +* used by a particular array in DLASD7 and DLASD8. +* + ISIGMA = 1 + IW = ISIGMA + N + IVFW = IW + M + IVLW = IVFW + M +* + IDX = 1 + IDXC = IDX + N + IDXP = IDXC + N +* +* Scale. +* + ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) ) + D( NL+1 ) = ZERO + DO 10 I = 1, N + IF( ABS( D( I ) ).GT.ORGNRM ) THEN + ORGNRM = ABS( D( I ) ) + END IF + 10 CONTINUE + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO ) + ALPHA = ALPHA / ORGNRM + BETA = BETA / ORGNRM +* +* Sort and Deflate singular values. +* + CALL DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, WORK( IW ), VF, + $ WORK( IVFW ), VL, WORK( IVLW ), ALPHA, BETA, + $ WORK( ISIGMA ), IWORK( IDX ), IWORK( IDXP ), IDXQ, + $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S, + $ INFO ) +* +* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL. +* + CALL DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDGNUM, + $ WORK( ISIGMA ), WORK( IW ), INFO ) +* +* Report the possible convergence failure. +* + IF( INFO.NE.0 ) THEN + RETURN + END IF +* +* Save the poles if ICOMPQ = 1. +* + IF( ICOMPQ.EQ.1 ) THEN + CALL DCOPY( K, D, 1, POLES( 1, 1 ), 1 ) + CALL DCOPY( K, WORK( ISIGMA ), 1, POLES( 1, 2 ), 1 ) + END IF +* +* Unscale. +* + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) +* +* Prepare the IDXQ sorting permutation. +* + N1 = K + N2 = N - K + CALL DLAMRG( N1, N2, D, 1, -1, IDXQ ) +* + RETURN +* +* End of DLASD6 +* + END diff --git a/math/lapack/src/main/fortran/dlasd7.f b/math/lapack/src/main/fortran/dlasd7.f new file mode 100644 index 0000000000..e0ddedeb57 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasd7.f @@ -0,0 +1,580 @@ +*> \brief \b DLASD7 merges the two sets of singular values together into a single sorted set. Then it tries to deflate the size of the problem. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASD7 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, +* VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, +* PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, +* C, S, INFO ) +* +* .. Scalar Arguments .. +* INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, +* $ NR, SQRE +* DOUBLE PRECISION ALPHA, BETA, C, S +* .. +* .. Array Arguments .. +* INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ), +* $ IDXQ( * ), PERM( * ) +* DOUBLE PRECISION D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ), +* $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), +* $ ZW( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASD7 merges the two sets of singular values together into a single +*> sorted set. Then it tries to deflate the size of the problem. There +*> are two ways in which deflation can occur: when two or more singular +*> values are close together or if there is a tiny entry in the Z +*> vector. For each such occurrence the order of the related +*> secular equation problem is reduced by one. +*> +*> DLASD7 is called from DLASD6. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ICOMPQ +*> \verbatim +*> ICOMPQ is INTEGER +*> Specifies whether singular vectors are to be computed +*> in compact form, as follows: +*> = 0: Compute singular values only. +*> = 1: Compute singular vectors of upper +*> bidiagonal matrix in compact form. +*> \endverbatim +*> +*> \param[in] NL +*> \verbatim +*> NL is INTEGER +*> The row dimension of the upper block. NL >= 1. +*> \endverbatim +*> +*> \param[in] NR +*> \verbatim +*> NR is INTEGER +*> The row dimension of the lower block. NR >= 1. +*> \endverbatim +*> +*> \param[in] SQRE +*> \verbatim +*> SQRE is INTEGER +*> = 0: the lower block is an NR-by-NR square matrix. +*> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. +*> +*> The bidiagonal matrix has +*> N = NL + NR + 1 rows and +*> M = N + SQRE >= N columns. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Contains the dimension of the non-deflated matrix, this is +*> the order of the related secular equation. 1 <= K <=N. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension ( N ) +*> On entry D contains the singular values of the two submatrices +*> to be combined. On exit D contains the trailing (N-K) updated +*> singular values (those which were deflated) sorted into +*> increasing order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( M ) +*> On exit Z contains the updating row vector in the secular +*> equation. +*> \endverbatim +*> +*> \param[out] ZW +*> \verbatim +*> ZW is DOUBLE PRECISION array, dimension ( M ) +*> Workspace for Z. +*> \endverbatim +*> +*> \param[in,out] VF +*> \verbatim +*> VF is DOUBLE PRECISION array, dimension ( M ) +*> On entry, VF(1:NL+1) contains the first components of all +*> right singular vectors of the upper block; and VF(NL+2:M) +*> contains the first components of all right singular vectors +*> of the lower block. On exit, VF contains the first components +*> of all right singular vectors of the bidiagonal matrix. +*> \endverbatim +*> +*> \param[out] VFW +*> \verbatim +*> VFW is DOUBLE PRECISION array, dimension ( M ) +*> Workspace for VF. +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is DOUBLE PRECISION array, dimension ( M ) +*> On entry, VL(1:NL+1) contains the last components of all +*> right singular vectors of the upper block; and VL(NL+2:M) +*> contains the last components of all right singular vectors +*> of the lower block. On exit, VL contains the last components +*> of all right singular vectors of the bidiagonal matrix. +*> \endverbatim +*> +*> \param[out] VLW +*> \verbatim +*> VLW is DOUBLE PRECISION array, dimension ( M ) +*> Workspace for VL. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> Contains the diagonal element associated with the added row. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION +*> Contains the off-diagonal element associated with the added +*> row. +*> \endverbatim +*> +*> \param[out] DSIGMA +*> \verbatim +*> DSIGMA is DOUBLE PRECISION array, dimension ( N ) +*> Contains a copy of the diagonal elements (K-1 singular values +*> and one zero) in the secular equation. +*> \endverbatim +*> +*> \param[out] IDX +*> \verbatim +*> IDX is INTEGER array, dimension ( N ) +*> This will contain the permutation used to sort the contents of +*> D into ascending order. +*> \endverbatim +*> +*> \param[out] IDXP +*> \verbatim +*> IDXP is INTEGER array, dimension ( N ) +*> This will contain the permutation used to place deflated +*> values of D at the end of the array. On output IDXP(2:K) +*> points to the nondeflated D-values and IDXP(K+1:N) +*> points to the deflated singular values. +*> \endverbatim +*> +*> \param[in] IDXQ +*> \verbatim +*> IDXQ is INTEGER array, dimension ( N ) +*> This contains the permutation which separately sorts the two +*> sub-problems in D into ascending order. Note that entries in +*> the first half of this permutation must first be moved one +*> position backward; and entries in the second half +*> must first have NL+1 added to their values. +*> \endverbatim +*> +*> \param[out] PERM +*> \verbatim +*> PERM is INTEGER array, dimension ( N ) +*> The permutations (from deflation and sorting) to be applied +*> to each singular block. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[out] GIVPTR +*> \verbatim +*> GIVPTR is INTEGER +*> The number of Givens rotations which took place in this +*> subproblem. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[out] GIVCOL +*> \verbatim +*> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) +*> Each pair of numbers indicates a pair of columns to take place +*> in a Givens rotation. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[in] LDGCOL +*> \verbatim +*> LDGCOL is INTEGER +*> The leading dimension of GIVCOL, must be at least N. +*> \endverbatim +*> +*> \param[out] GIVNUM +*> \verbatim +*> GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) +*> Each number indicates the C or S value to be used in the +*> corresponding Givens rotation. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[in] LDGNUM +*> \verbatim +*> LDGNUM is INTEGER +*> The leading dimension of GIVNUM, must be at least N. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION +*> C contains garbage if SQRE =0 and the C-value of a Givens +*> rotation related to the right null space if SQRE = 1. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION +*> S contains garbage if SQRE =0 and the S-value of a Givens +*> rotation related to the right null space if SQRE = 1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, + $ VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, + $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, + $ C, S, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, + $ NR, SQRE + DOUBLE PRECISION ALPHA, BETA, C, S +* .. +* .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ), + $ IDXQ( * ), PERM( * ) + DOUBLE PRECISION D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ), + $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), + $ ZW( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, EIGHT + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ EIGHT = 8.0D+0 ) +* .. +* .. Local Scalars .. +* + INTEGER I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N, + $ NLP1, NLP2 + DOUBLE PRECISION EPS, HLFTOL, TAU, TOL, Z1 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLAMRG, DROT, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + N = NL + NR + 1 + M = N + SQRE +* + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( NL.LT.1 ) THEN + INFO = -2 + ELSE IF( NR.LT.1 ) THEN + INFO = -3 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -4 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -22 + ELSE IF( LDGNUM.LT.N ) THEN + INFO = -24 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD7', -INFO ) + RETURN + END IF +* + NLP1 = NL + 1 + NLP2 = NL + 2 + IF( ICOMPQ.EQ.1 ) THEN + GIVPTR = 0 + END IF +* +* Generate the first part of the vector Z and move the singular +* values in the first part of D one position backward. +* + Z1 = ALPHA*VL( NLP1 ) + VL( NLP1 ) = ZERO + TAU = VF( NLP1 ) + DO 10 I = NL, 1, -1 + Z( I+1 ) = ALPHA*VL( I ) + VL( I ) = ZERO + VF( I+1 ) = VF( I ) + D( I+1 ) = D( I ) + IDXQ( I+1 ) = IDXQ( I ) + 1 + 10 CONTINUE + VF( 1 ) = TAU +* +* Generate the second part of the vector Z. +* + DO 20 I = NLP2, M + Z( I ) = BETA*VF( I ) + VF( I ) = ZERO + 20 CONTINUE +* +* Sort the singular values into increasing order +* + DO 30 I = NLP2, N + IDXQ( I ) = IDXQ( I ) + NLP1 + 30 CONTINUE +* +* DSIGMA, IDXC, IDXC, and ZW are used as storage space. +* + DO 40 I = 2, N + DSIGMA( I ) = D( IDXQ( I ) ) + ZW( I ) = Z( IDXQ( I ) ) + VFW( I ) = VF( IDXQ( I ) ) + VLW( I ) = VL( IDXQ( I ) ) + 40 CONTINUE +* + CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) ) +* + DO 50 I = 2, N + IDXI = 1 + IDX( I ) + D( I ) = DSIGMA( IDXI ) + Z( I ) = ZW( IDXI ) + VF( I ) = VFW( IDXI ) + VL( I ) = VLW( IDXI ) + 50 CONTINUE +* +* Calculate the allowable deflation tolerence +* + EPS = DLAMCH( 'Epsilon' ) + TOL = MAX( ABS( ALPHA ), ABS( BETA ) ) + TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL ) +* +* There are 2 kinds of deflation -- first a value in the z-vector +* is small, second two (or more) singular values are very close +* together (their difference is small). +* +* If the value in the z-vector is small, we simply permute the +* array so that the corresponding singular value is moved to the +* end. +* +* If two values in the D-vector are close, we perform a two-sided +* rotation designed to make one of the corresponding z-vector +* entries zero, and then permute the array so that the deflated +* singular value is moved to the end. +* +* If there are multiple singular values then the problem deflates. +* Here the number of equal singular values are found. As each equal +* singular value is found, an elementary reflector is computed to +* rotate the corresponding singular subspace so that the +* corresponding components of Z are zero in this new basis. +* + K = 1 + K2 = N + 1 + DO 60 J = 2, N + IF( ABS( Z( J ) ).LE.TOL ) THEN +* +* Deflate due to small z component. +* + K2 = K2 - 1 + IDXP( K2 ) = J + IF( J.EQ.N ) + $ GO TO 100 + ELSE + JPREV = J + GO TO 70 + END IF + 60 CONTINUE + 70 CONTINUE + J = JPREV + 80 CONTINUE + J = J + 1 + IF( J.GT.N ) + $ GO TO 90 + IF( ABS( Z( J ) ).LE.TOL ) THEN +* +* Deflate due to small z component. +* + K2 = K2 - 1 + IDXP( K2 ) = J + ELSE +* +* Check if singular values are close enough to allow deflation. +* + IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN +* +* Deflation is possible. +* + S = Z( JPREV ) + C = Z( J ) +* +* Find sqrt(a**2+b**2) without overflow or +* destructive underflow. +* + TAU = DLAPY2( C, S ) + Z( J ) = TAU + Z( JPREV ) = ZERO + C = C / TAU + S = -S / TAU +* +* Record the appropriate Givens rotation +* + IF( ICOMPQ.EQ.1 ) THEN + GIVPTR = GIVPTR + 1 + IDXJP = IDXQ( IDX( JPREV )+1 ) + IDXJ = IDXQ( IDX( J )+1 ) + IF( IDXJP.LE.NLP1 ) THEN + IDXJP = IDXJP - 1 + END IF + IF( IDXJ.LE.NLP1 ) THEN + IDXJ = IDXJ - 1 + END IF + GIVCOL( GIVPTR, 2 ) = IDXJP + GIVCOL( GIVPTR, 1 ) = IDXJ + GIVNUM( GIVPTR, 2 ) = C + GIVNUM( GIVPTR, 1 ) = S + END IF + CALL DROT( 1, VF( JPREV ), 1, VF( J ), 1, C, S ) + CALL DROT( 1, VL( JPREV ), 1, VL( J ), 1, C, S ) + K2 = K2 - 1 + IDXP( K2 ) = JPREV + JPREV = J + ELSE + K = K + 1 + ZW( K ) = Z( JPREV ) + DSIGMA( K ) = D( JPREV ) + IDXP( K ) = JPREV + JPREV = J + END IF + END IF + GO TO 80 + 90 CONTINUE +* +* Record the last singular value. +* + K = K + 1 + ZW( K ) = Z( JPREV ) + DSIGMA( K ) = D( JPREV ) + IDXP( K ) = JPREV +* + 100 CONTINUE +* +* Sort the singular values into DSIGMA. The singular values which +* were not deflated go into the first K slots of DSIGMA, except +* that DSIGMA(1) is treated separately. +* + DO 110 J = 2, N + JP = IDXP( J ) + DSIGMA( J ) = D( JP ) + VFW( J ) = VF( JP ) + VLW( J ) = VL( JP ) + 110 CONTINUE + IF( ICOMPQ.EQ.1 ) THEN + DO 120 J = 2, N + JP = IDXP( J ) + PERM( J ) = IDXQ( IDX( JP )+1 ) + IF( PERM( J ).LE.NLP1 ) THEN + PERM( J ) = PERM( J ) - 1 + END IF + 120 CONTINUE + END IF +* +* The deflated singular values go back into the last N - K slots of +* D. +* + CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 ) +* +* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and +* VL(M). +* + DSIGMA( 1 ) = ZERO + HLFTOL = TOL / TWO + IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL ) + $ DSIGMA( 2 ) = HLFTOL + IF( M.GT.N ) THEN + Z( 1 ) = DLAPY2( Z1, Z( M ) ) + IF( Z( 1 ).LE.TOL ) THEN + C = ONE + S = ZERO + Z( 1 ) = TOL + ELSE + C = Z1 / Z( 1 ) + S = -Z( M ) / Z( 1 ) + END IF + CALL DROT( 1, VF( M ), 1, VF( 1 ), 1, C, S ) + CALL DROT( 1, VL( M ), 1, VL( 1 ), 1, C, S ) + ELSE + IF( ABS( Z1 ).LE.TOL ) THEN + Z( 1 ) = TOL + ELSE + Z( 1 ) = Z1 + END IF + END IF +* +* Restore Z, VF, and VL. +* + CALL DCOPY( K-1, ZW( 2 ), 1, Z( 2 ), 1 ) + CALL DCOPY( N-1, VFW( 2 ), 1, VF( 2 ), 1 ) + CALL DCOPY( N-1, VLW( 2 ), 1, VL( 2 ), 1 ) +* + RETURN +* +* End of DLASD7 +* + END diff --git a/math/lapack/src/main/fortran/dlasd8.f b/math/lapack/src/main/fortran/dlasd8.f new file mode 100644 index 0000000000..245e814a15 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasd8.f @@ -0,0 +1,342 @@ +*> \brief \b DLASD8 finds the square roots of the roots of the secular equation, and stores, for each element in D, the distance to its two nearest poles. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASD8 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, +* DSIGMA, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER ICOMPQ, INFO, K, LDDIFR +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ), +* $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ), +* $ Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASD8 finds the square roots of the roots of the secular equation, +*> as defined by the values in DSIGMA and Z. It makes the appropriate +*> calls to DLASD4, and stores, for each element in D, the distance +*> to its two nearest poles (elements in DSIGMA). It also updates +*> the arrays VF and VL, the first and last components of all the +*> right singular vectors of the original bidiagonal matrix. +*> +*> DLASD8 is called from DLASD6. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ICOMPQ +*> \verbatim +*> ICOMPQ is INTEGER +*> Specifies whether singular vectors are to be computed in +*> factored form in the calling routine: +*> = 0: Compute singular values only. +*> = 1: Compute singular vectors in factored form as well. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of terms in the rational function to be solved +*> by DLASD4. K >= 1. +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension ( K ) +*> On output, D contains the updated singular values. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( K ) +*> On entry, the first K elements of this array contain the +*> components of the deflation-adjusted updating row vector. +*> On exit, Z is updated. +*> \endverbatim +*> +*> \param[in,out] VF +*> \verbatim +*> VF is DOUBLE PRECISION array, dimension ( K ) +*> On entry, VF contains information passed through DBEDE8. +*> On exit, VF contains the first K components of the first +*> components of all right singular vectors of the bidiagonal +*> matrix. +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is DOUBLE PRECISION array, dimension ( K ) +*> On entry, VL contains information passed through DBEDE8. +*> On exit, VL contains the first K components of the last +*> components of all right singular vectors of the bidiagonal +*> matrix. +*> \endverbatim +*> +*> \param[out] DIFL +*> \verbatim +*> DIFL is DOUBLE PRECISION array, dimension ( K ) +*> On exit, DIFL(I) = D(I) - DSIGMA(I). +*> \endverbatim +*> +*> \param[out] DIFR +*> \verbatim +*> DIFR is DOUBLE PRECISION array, +*> dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and +*> dimension ( K ) if ICOMPQ = 0. +*> On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not +*> defined and will not be referenced. +*> +*> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the +*> normalizing factors for the right singular vector matrix. +*> \endverbatim +*> +*> \param[in] LDDIFR +*> \verbatim +*> LDDIFR is INTEGER +*> The leading dimension of DIFR, must be at least K. +*> \endverbatim +*> +*> \param[in,out] DSIGMA +*> \verbatim +*> DSIGMA is DOUBLE PRECISION array, dimension ( K ) +*> On entry, the first K elements of this array contain the old +*> roots of the deflated updating problem. These are the poles +*> of the secular equation. +*> On exit, the elements of DSIGMA may be very slightly altered +*> in value. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension at least 3 * K +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = 1, a singular value did not converge +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, + $ DSIGMA, WORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER ICOMPQ, INFO, K, LDDIFR +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ), + $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ), + $ Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J + DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLASCL, DLASD4, DLASET, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DDOT, DLAMC3, DNRM2 + EXTERNAL DDOT, DLAMC3, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( K.LT.1 ) THEN + INFO = -2 + ELSE IF( LDDIFR.LT.K ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD8', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( K.EQ.1 ) THEN + D( 1 ) = ABS( Z( 1 ) ) + DIFL( 1 ) = D( 1 ) + IF( ICOMPQ.EQ.1 ) THEN + DIFL( 2 ) = ONE + DIFR( 1, 2 ) = ONE + END IF + RETURN + END IF +* +* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can +* be computed with high relative accuracy (barring over/underflow). +* This is a problem on machines without a guard digit in +* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). +* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), +* which on any of these machines zeros out the bottommost +* bit of DSIGMA(I) if it is 1; this makes the subsequent +* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation +* occurs. On binary machines with a guard digit (almost all +* machines) it does not change DSIGMA(I) at all. On hexadecimal +* and decimal machines with a guard digit, it slightly +* changes the bottommost bits of DSIGMA(I). It does not account +* for hexadecimal or decimal machines without guard digits +* (we know of none). We use a subroutine call to compute +* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating +* this code. +* + DO 10 I = 1, K + DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I ) + 10 CONTINUE +* +* Book keeping. +* + IWK1 = 1 + IWK2 = IWK1 + K + IWK3 = IWK2 + K + IWK2I = IWK2 - 1 + IWK3I = IWK3 - 1 +* +* Normalize Z. +* + RHO = DNRM2( K, Z, 1 ) + CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO ) + RHO = RHO*RHO +* +* Initialize WORK(IWK3). +* + CALL DLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K ) +* +* Compute the updated singular values, the arrays DIFL, DIFR, +* and the updated Z. +* + DO 40 J = 1, K + CALL DLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ), + $ WORK( IWK2 ), INFO ) +* +* If the root finder fails, report the convergence failure. +* + IF( INFO.NE.0 ) THEN + RETURN + END IF + WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J ) + DIFL( J ) = -WORK( J ) + DIFR( J, 1 ) = -WORK( J+1 ) + DO 20 I = 1, J - 1 + WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )* + $ WORK( IWK2I+I ) / ( DSIGMA( I )- + $ DSIGMA( J ) ) / ( DSIGMA( I )+ + $ DSIGMA( J ) ) + 20 CONTINUE + DO 30 I = J + 1, K + WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )* + $ WORK( IWK2I+I ) / ( DSIGMA( I )- + $ DSIGMA( J ) ) / ( DSIGMA( I )+ + $ DSIGMA( J ) ) + 30 CONTINUE + 40 CONTINUE +* +* Compute updated Z. +* + DO 50 I = 1, K + Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) ) + 50 CONTINUE +* +* Update VF and VL. +* + DO 80 J = 1, K + DIFLJ = DIFL( J ) + DJ = D( J ) + DSIGJ = -DSIGMA( J ) + IF( J.LT.K ) THEN + DIFRJ = -DIFR( J, 1 ) + DSIGJP = -DSIGMA( J+1 ) + END IF + WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ ) + DO 60 I = 1, J - 1 + WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ ) + $ / ( DSIGMA( I )+DJ ) + 60 CONTINUE + DO 70 I = J + 1, K + WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ ) + $ / ( DSIGMA( I )+DJ ) + 70 CONTINUE + TEMP = DNRM2( K, WORK, 1 ) + WORK( IWK2I+J ) = DDOT( K, WORK, 1, VF, 1 ) / TEMP + WORK( IWK3I+J ) = DDOT( K, WORK, 1, VL, 1 ) / TEMP + IF( ICOMPQ.EQ.1 ) THEN + DIFR( J, 2 ) = TEMP + END IF + 80 CONTINUE +* + CALL DCOPY( K, WORK( IWK2 ), 1, VF, 1 ) + CALL DCOPY( K, WORK( IWK3 ), 1, VL, 1 ) +* + RETURN +* +* End of DLASD8 +* + END + diff --git a/math/lapack/src/main/fortran/dlasda.f b/math/lapack/src/main/fortran/dlasda.f new file mode 100644 index 0000000000..20ceedd0be --- /dev/null +++ b/math/lapack/src/main/fortran/dlasda.f @@ -0,0 +1,515 @@ +*> \brief \b DLASDA computes the singular value decomposition (SVD) of a real upper bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASDA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, +* DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, +* PERM, GIVNUM, C, S, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE +* .. +* .. Array Arguments .. +* INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), +* $ K( * ), PERM( LDGCOL, * ) +* DOUBLE PRECISION C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ), +* $ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ), +* $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), +* $ Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Using a divide and conquer approach, DLASDA computes the singular +*> value decomposition (SVD) of a real upper bidiagonal N-by-M matrix +*> B with diagonal D and offdiagonal E, where M = N + SQRE. The +*> algorithm computes the singular values in the SVD B = U * S * VT. +*> The orthogonal matrices U and VT are optionally computed in +*> compact form. +*> +*> A related subroutine, DLASD0, computes the singular values and +*> the singular vectors in explicit form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ICOMPQ +*> \verbatim +*> ICOMPQ is INTEGER +*> Specifies whether singular vectors are to be computed +*> in compact form, as follows +*> = 0: Compute singular values only. +*> = 1: Compute singular vectors of upper bidiagonal +*> matrix in compact form. +*> \endverbatim +*> +*> \param[in] SMLSIZ +*> \verbatim +*> SMLSIZ is INTEGER +*> The maximum size of the subproblems at the bottom of the +*> computation tree. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The row dimension of the upper bidiagonal matrix. This is +*> also the dimension of the main diagonal array D. +*> \endverbatim +*> +*> \param[in] SQRE +*> \verbatim +*> SQRE is INTEGER +*> Specifies the column dimension of the bidiagonal matrix. +*> = 0: The bidiagonal matrix has column dimension M = N; +*> = 1: The bidiagonal matrix has column dimension M = N + 1. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension ( N ) +*> On entry D contains the main diagonal of the bidiagonal +*> matrix. On exit D, if INFO = 0, contains its singular values. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension ( M-1 ) +*> Contains the subdiagonal entries of the bidiagonal matrix. +*> On exit, E has been destroyed. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is DOUBLE PRECISION array, +*> dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced +*> if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left +*> singular vector matrices of all subproblems at the bottom +*> level. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER, LDU = > N. +*> The leading dimension of arrays U, VT, DIFL, DIFR, POLES, +*> GIVNUM, and Z. +*> \endverbatim +*> +*> \param[out] VT +*> \verbatim +*> VT is DOUBLE PRECISION array, +*> dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced +*> if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT**T contains the right +*> singular vector matrices of all subproblems at the bottom +*> level. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER array, +*> dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. +*> If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th +*> secular equation on the computation tree. +*> \endverbatim +*> +*> \param[out] DIFL +*> \verbatim +*> DIFL is DOUBLE PRECISION array, dimension ( LDU, NLVL ), +*> where NLVL = floor(log_2 (N/SMLSIZ))). +*> \endverbatim +*> +*> \param[out] DIFR +*> \verbatim +*> DIFR is DOUBLE PRECISION array, +*> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and +*> dimension ( N ) if ICOMPQ = 0. +*> If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) +*> record distances between singular values on the I-th +*> level and singular values on the (I -1)-th level, and +*> DIFR(1:N, 2 * I ) contains the normalizing factors for +*> the right singular vector matrix. See DLASD8 for details. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, +*> dimension ( LDU, NLVL ) if ICOMPQ = 1 and +*> dimension ( N ) if ICOMPQ = 0. +*> The first K elements of Z(1, I) contain the components of +*> the deflation-adjusted updating row vector for subproblems +*> on the I-th level. +*> \endverbatim +*> +*> \param[out] POLES +*> \verbatim +*> POLES is DOUBLE PRECISION array, +*> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced +*> if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and +*> POLES(1, 2*I) contain the new and old singular values +*> involved in the secular equations on the I-th level. +*> \endverbatim +*> +*> \param[out] GIVPTR +*> \verbatim +*> GIVPTR is INTEGER array, +*> dimension ( N ) if ICOMPQ = 1, and not referenced if +*> ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records +*> the number of Givens rotations performed on the I-th +*> problem on the computation tree. +*> \endverbatim +*> +*> \param[out] GIVCOL +*> \verbatim +*> GIVCOL is INTEGER array, +*> dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not +*> referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, +*> GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations +*> of Givens rotations performed on the I-th level on the +*> computation tree. +*> \endverbatim +*> +*> \param[in] LDGCOL +*> \verbatim +*> LDGCOL is INTEGER, LDGCOL = > N. +*> The leading dimension of arrays GIVCOL and PERM. +*> \endverbatim +*> +*> \param[out] PERM +*> \verbatim +*> PERM is INTEGER array, +*> dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced +*> if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records +*> permutations done on the I-th level of the computation tree. +*> \endverbatim +*> +*> \param[out] GIVNUM +*> \verbatim +*> GIVNUM is DOUBLE PRECISION array, +*> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not +*> referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, +*> GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- +*> values of Givens rotations performed on the I-th level on +*> the computation tree. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array, +*> dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. +*> If ICOMPQ = 1 and the I-th subproblem is not square, on exit, +*> C( I ) contains the C-value of a Givens rotation related to +*> the right null space of the I-th subproblem. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension ( N ) if +*> ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 +*> and the I-th subproblem is not square, on exit, S( I ) +*> contains the S-value of a Givens rotation related to +*> the right null space of the I-th subproblem. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array. +*> Dimension must be at least (7 * N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = 1, a singular value did not converge +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, + $ DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, + $ PERM, GIVNUM, C, S, WORK, IWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE +* .. +* .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), + $ K( * ), PERM( LDGCOL, * ) + DOUBLE PRECISION C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ), + $ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ), + $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), + $ Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK, + $ J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML, + $ NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU, + $ NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI + DOUBLE PRECISION ALPHA, BETA +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLASD6, DLASDQ, DLASDT, DLASET, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( SMLSIZ.LT.3 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -4 + ELSE IF( LDU.LT.( N+SQRE ) ) THEN + INFO = -8 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -17 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASDA', -INFO ) + RETURN + END IF +* + M = N + SQRE +* +* If the input matrix is too small, call DLASDQ to find the SVD. +* + IF( N.LE.SMLSIZ ) THEN + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASDQ( 'U', SQRE, N, 0, 0, 0, D, E, VT, LDU, U, LDU, + $ U, LDU, WORK, INFO ) + ELSE + CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDU, U, LDU, + $ U, LDU, WORK, INFO ) + END IF + RETURN + END IF +* +* Book-keeping and set up the computation tree. +* + INODE = 1 + NDIML = INODE + N + NDIMR = NDIML + N + IDXQ = NDIMR + N + IWK = IDXQ + N +* + NCC = 0 + NRU = 0 +* + SMLSZP = SMLSIZ + 1 + VF = 1 + VL = VF + M + NWORK1 = VL + M + NWORK2 = NWORK1 + SMLSZP*SMLSZP +* + CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), + $ IWORK( NDIMR ), SMLSIZ ) +* +* for the nodes on bottom level of the tree, solve +* their subproblems by DLASDQ. +* + NDB1 = ( ND+1 ) / 2 + DO 30 I = NDB1, ND +* +* IC : center row of each node +* NL : number of rows of left subproblem +* NR : number of rows of right subproblem +* NLF: starting row of the left subproblem +* NRF: starting row of the right subproblem +* + I1 = I - 1 + IC = IWORK( INODE+I1 ) + NL = IWORK( NDIML+I1 ) + NLP1 = NL + 1 + NR = IWORK( NDIMR+I1 ) + NLF = IC - NL + NRF = IC + 1 + IDXQI = IDXQ + NLF - 2 + VFI = VF + NLF - 1 + VLI = VL + NLF - 1 + SQREI = 1 + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, WORK( NWORK1 ), + $ SMLSZP ) + CALL DLASDQ( 'U', SQREI, NL, NLP1, NRU, NCC, D( NLF ), + $ E( NLF ), WORK( NWORK1 ), SMLSZP, + $ WORK( NWORK2 ), NL, WORK( NWORK2 ), NL, + $ WORK( NWORK2 ), INFO ) + ITEMP = NWORK1 + NL*SMLSZP + CALL DCOPY( NLP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 ) + CALL DCOPY( NLP1, WORK( ITEMP ), 1, WORK( VLI ), 1 ) + ELSE + CALL DLASET( 'A', NL, NL, ZERO, ONE, U( NLF, 1 ), LDU ) + CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, VT( NLF, 1 ), LDU ) + CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), + $ E( NLF ), VT( NLF, 1 ), LDU, U( NLF, 1 ), LDU, + $ U( NLF, 1 ), LDU, WORK( NWORK1 ), INFO ) + CALL DCOPY( NLP1, VT( NLF, 1 ), 1, WORK( VFI ), 1 ) + CALL DCOPY( NLP1, VT( NLF, NLP1 ), 1, WORK( VLI ), 1 ) + END IF + IF( INFO.NE.0 ) THEN + RETURN + END IF + DO 10 J = 1, NL + IWORK( IDXQI+J ) = J + 10 CONTINUE + IF( ( I.EQ.ND ) .AND. ( SQRE.EQ.0 ) ) THEN + SQREI = 0 + ELSE + SQREI = 1 + END IF + IDXQI = IDXQI + NLP1 + VFI = VFI + NLP1 + VLI = VLI + NLP1 + NRP1 = NR + SQREI + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, WORK( NWORK1 ), + $ SMLSZP ) + CALL DLASDQ( 'U', SQREI, NR, NRP1, NRU, NCC, D( NRF ), + $ E( NRF ), WORK( NWORK1 ), SMLSZP, + $ WORK( NWORK2 ), NR, WORK( NWORK2 ), NR, + $ WORK( NWORK2 ), INFO ) + ITEMP = NWORK1 + ( NRP1-1 )*SMLSZP + CALL DCOPY( NRP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 ) + CALL DCOPY( NRP1, WORK( ITEMP ), 1, WORK( VLI ), 1 ) + ELSE + CALL DLASET( 'A', NR, NR, ZERO, ONE, U( NRF, 1 ), LDU ) + CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, VT( NRF, 1 ), LDU ) + CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), + $ E( NRF ), VT( NRF, 1 ), LDU, U( NRF, 1 ), LDU, + $ U( NRF, 1 ), LDU, WORK( NWORK1 ), INFO ) + CALL DCOPY( NRP1, VT( NRF, 1 ), 1, WORK( VFI ), 1 ) + CALL DCOPY( NRP1, VT( NRF, NRP1 ), 1, WORK( VLI ), 1 ) + END IF + IF( INFO.NE.0 ) THEN + RETURN + END IF + DO 20 J = 1, NR + IWORK( IDXQI+J ) = J + 20 CONTINUE + 30 CONTINUE +* +* Now conquer each subproblem bottom-up. +* + J = 2**NLVL + DO 50 LVL = NLVL, 1, -1 + LVL2 = LVL*2 - 1 +* +* Find the first node LF and last node LL on +* the current level LVL. +* + IF( LVL.EQ.1 ) THEN + LF = 1 + LL = 1 + ELSE + LF = 2**( LVL-1 ) + LL = 2*LF - 1 + END IF + DO 40 I = LF, LL + IM1 = I - 1 + IC = IWORK( INODE+IM1 ) + NL = IWORK( NDIML+IM1 ) + NR = IWORK( NDIMR+IM1 ) + NLF = IC - NL + NRF = IC + 1 + IF( I.EQ.LL ) THEN + SQREI = SQRE + ELSE + SQREI = 1 + END IF + VFI = VF + NLF - 1 + VLI = VL + NLF - 1 + IDXQI = IDXQ + NLF - 1 + ALPHA = D( IC ) + BETA = E( IC ) + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ), + $ WORK( VFI ), WORK( VLI ), ALPHA, BETA, + $ IWORK( IDXQI ), PERM, GIVPTR( 1 ), GIVCOL, + $ LDGCOL, GIVNUM, LDU, POLES, DIFL, DIFR, Z, + $ K( 1 ), C( 1 ), S( 1 ), WORK( NWORK1 ), + $ IWORK( IWK ), INFO ) + ELSE + J = J - 1 + CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ), + $ WORK( VFI ), WORK( VLI ), ALPHA, BETA, + $ IWORK( IDXQI ), PERM( NLF, LVL ), + $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, + $ GIVNUM( NLF, LVL2 ), LDU, + $ POLES( NLF, LVL2 ), DIFL( NLF, LVL ), + $ DIFR( NLF, LVL2 ), Z( NLF, LVL ), K( J ), + $ C( J ), S( J ), WORK( NWORK1 ), + $ IWORK( IWK ), INFO ) + END IF + IF( INFO.NE.0 ) THEN + RETURN + END IF + 40 CONTINUE + 50 CONTINUE +* + RETURN +* +* End of DLASDA +* + END diff --git a/math/lapack/src/main/fortran/dlasdq.f b/math/lapack/src/main/fortran/dlasdq.f new file mode 100644 index 0000000000..e7d3575a98 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasdq.f @@ -0,0 +1,413 @@ +*> \brief \b DLASDQ computes the SVD of a real bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASDQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, +* U, LDU, C, LDC, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), +* $ VT( LDVT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASDQ computes the singular value decomposition (SVD) of a real +*> (upper or lower) bidiagonal matrix with diagonal D and offdiagonal +*> E, accumulating the transformations if desired. Letting B denote +*> the input bidiagonal matrix, the algorithm computes orthogonal +*> matrices Q and P such that B = Q * S * P**T (P**T denotes the transpose +*> of P). The singular values S are overwritten on D. +*> +*> The input matrix U is changed to U * Q if desired. +*> The input matrix VT is changed to P**T * VT if desired. +*> The input matrix C is changed to Q**T * C if desired. +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices With +*> Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, +*> LAPACK Working Note #3, for a detailed description of the algorithm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the input bidiagonal matrix +*> is upper or lower bidiagonal, and whether it is square are +*> not. +*> UPLO = 'U' or 'u' B is upper bidiagonal. +*> UPLO = 'L' or 'l' B is lower bidiagonal. +*> \endverbatim +*> +*> \param[in] SQRE +*> \verbatim +*> SQRE is INTEGER +*> = 0: then the input matrix is N-by-N. +*> = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and +*> (N+1)-by-N if UPLU = 'L'. +*> +*> The bidiagonal matrix has +*> N = NL + NR + 1 rows and +*> M = N + SQRE >= N columns. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of rows and columns +*> in the matrix. N must be at least 0. +*> \endverbatim +*> +*> \param[in] NCVT +*> \verbatim +*> NCVT is INTEGER +*> On entry, NCVT specifies the number of columns of +*> the matrix VT. NCVT must be at least 0. +*> \endverbatim +*> +*> \param[in] NRU +*> \verbatim +*> NRU is INTEGER +*> On entry, NRU specifies the number of rows of +*> the matrix U. NRU must be at least 0. +*> \endverbatim +*> +*> \param[in] NCC +*> \verbatim +*> NCC is INTEGER +*> On entry, NCC specifies the number of columns of +*> the matrix C. NCC must be at least 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, D contains the diagonal entries of the +*> bidiagonal matrix whose SVD is desired. On normal exit, +*> D contains the singular values in ascending order. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array. +*> dimension is (N-1) if SQRE = 0 and N if SQRE = 1. +*> On entry, the entries of E contain the offdiagonal entries +*> of the bidiagonal matrix whose SVD is desired. On normal +*> exit, E will contain 0. If the algorithm does not converge, +*> D and E will contain the diagonal and superdiagonal entries +*> of a bidiagonal matrix orthogonally equivalent to the one +*> given as input. +*> \endverbatim +*> +*> \param[in,out] VT +*> \verbatim +*> VT is DOUBLE PRECISION array, dimension (LDVT, NCVT) +*> On entry, contains a matrix which on exit has been +*> premultiplied by P**T, dimension N-by-NCVT if SQRE = 0 +*> and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). +*> \endverbatim +*> +*> \param[in] LDVT +*> \verbatim +*> LDVT is INTEGER +*> On entry, LDVT specifies the leading dimension of VT as +*> declared in the calling (sub) program. LDVT must be at +*> least 1. If NCVT is nonzero LDVT must also be at least N. +*> \endverbatim +*> +*> \param[in,out] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension (LDU, N) +*> On entry, contains a matrix which on exit has been +*> postmultiplied by Q, dimension NRU-by-N if SQRE = 0 +*> and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> On entry, LDU specifies the leading dimension of U as +*> declared in the calling (sub) program. LDU must be at +*> least max( 1, NRU ) . +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC, NCC) +*> On entry, contains an N-by-NCC matrix which on exit +*> has been premultiplied by Q**T dimension N-by-NCC if SQRE = 0 +*> and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the leading dimension of C as +*> declared in the calling (sub) program. LDC must be at +*> least 1. If NCC is nonzero, LDC must also be at least N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> Workspace. Only referenced if one of NCVT, NRU, or NCC is +*> nonzero, and if N is at least 2. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> On exit, a value of 0 indicates a successful exit. +*> If INFO < 0, argument number -INFO is illegal. +*> If INFO > 0, the algorithm did not converge, and INFO +*> specifies how many superdiagonals did not converge. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, + $ U, LDU, C, LDC, WORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), + $ VT( LDVT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ROTATE + INTEGER I, ISUB, IUPLO, J, NP1, SQRE1 + DOUBLE PRECISION CS, R, SMIN, SN +* .. +* .. External Subroutines .. + EXTERNAL DBDSQR, DLARTG, DLASR, DSWAP, XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IUPLO = 0 + IF( LSAME( UPLO, 'U' ) ) + $ IUPLO = 1 + IF( LSAME( UPLO, 'L' ) ) + $ IUPLO = 2 + IF( IUPLO.EQ.0 ) THEN + INFO = -1 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NCVT.LT.0 ) THEN + INFO = -4 + ELSE IF( NRU.LT.0 ) THEN + INFO = -5 + ELSE IF( NCC.LT.0 ) THEN + INFO = -6 + ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. + $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN + INFO = -10 + ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN + INFO = -12 + ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. + $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN + INFO = -14 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASDQ', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN +* +* ROTATE is true if any singular vectors desired, false otherwise +* + ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) + NP1 = N + 1 + SQRE1 = SQRE +* +* If matrix non-square upper bidiagonal, rotate to be lower +* bidiagonal. The rotations are on the right. +* + IF( ( IUPLO.EQ.1 ) .AND. ( SQRE1.EQ.1 ) ) 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 ) + IF( ROTATE ) THEN + WORK( I ) = CS + WORK( N+I ) = SN + END IF + 10 CONTINUE + CALL DLARTG( D( N ), E( N ), CS, SN, R ) + D( N ) = R + E( N ) = ZERO + IF( ROTATE ) THEN + WORK( N ) = CS + WORK( N+N ) = SN + END IF + IUPLO = 2 + SQRE1 = 0 +* +* Update singular vectors if desired. +* + IF( NCVT.GT.0 ) + $ CALL DLASR( 'L', 'V', 'F', NP1, NCVT, WORK( 1 ), + $ WORK( NP1 ), VT, LDVT ) + END IF +* +* If matrix lower bidiagonal, rotate to be upper bidiagonal +* by applying Givens rotations on the left. +* + IF( IUPLO.EQ.2 ) THEN + DO 20 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 ) + IF( ROTATE ) THEN + WORK( I ) = CS + WORK( N+I ) = SN + END IF + 20 CONTINUE +* +* If matrix (N+1)-by-N lower bidiagonal, one additional +* rotation is needed. +* + IF( SQRE1.EQ.1 ) THEN + CALL DLARTG( D( N ), E( N ), CS, SN, R ) + D( N ) = R + IF( ROTATE ) THEN + WORK( N ) = CS + WORK( N+N ) = SN + END IF + END IF +* +* Update singular vectors if desired. +* + IF( NRU.GT.0 ) THEN + IF( SQRE1.EQ.0 ) THEN + CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), + $ WORK( NP1 ), U, LDU ) + ELSE + CALL DLASR( 'R', 'V', 'F', NRU, NP1, WORK( 1 ), + $ WORK( NP1 ), U, LDU ) + END IF + END IF + IF( NCC.GT.0 ) THEN + IF( SQRE1.EQ.0 ) THEN + CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), + $ WORK( NP1 ), C, LDC ) + ELSE + CALL DLASR( 'L', 'V', 'F', NP1, NCC, WORK( 1 ), + $ WORK( NP1 ), C, LDC ) + END IF + END IF + END IF +* +* Call DBDSQR to compute the SVD of the reduced real +* N-by-N upper bidiagonal matrix. +* + CALL DBDSQR( 'U', N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, + $ LDC, WORK, INFO ) +* +* Sort the singular values into ascending order (insertion sort on +* singular values, but only one transposition per singular vector) +* + DO 40 I = 1, N +* +* Scan for smallest D(I). +* + ISUB = I + SMIN = D( I ) + DO 30 J = I + 1, N + IF( D( J ).LT.SMIN ) THEN + ISUB = J + SMIN = D( J ) + END IF + 30 CONTINUE + IF( ISUB.NE.I ) THEN +* +* Swap singular values and vectors. +* + D( ISUB ) = D( I ) + D( I ) = SMIN + IF( NCVT.GT.0 ) + $ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( I, 1 ), LDVT ) + IF( NRU.GT.0 ) + $ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, I ), 1 ) + IF( NCC.GT.0 ) + $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( I, 1 ), LDC ) + END IF + 40 CONTINUE +* + RETURN +* +* End of DLASDQ +* + END diff --git a/math/lapack/src/main/fortran/dlasdt.f b/math/lapack/src/main/fortran/dlasdt.f new file mode 100644 index 0000000000..37da2d035e --- /dev/null +++ b/math/lapack/src/main/fortran/dlasdt.f @@ -0,0 +1,172 @@ +*> \brief \b DLASDT creates a tree of subproblems for bidiagonal divide and conquer. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASDT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) +* +* .. Scalar Arguments .. +* INTEGER LVL, MSUB, N, ND +* .. +* .. Array Arguments .. +* INTEGER INODE( * ), NDIML( * ), NDIMR( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASDT creates a tree of subproblems for bidiagonal divide and +*> conquer. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, the number of diagonal elements of the +*> bidiagonal matrix. +*> \endverbatim +*> +*> \param[out] LVL +*> \verbatim +*> LVL is INTEGER +*> On exit, the number of levels on the computation tree. +*> \endverbatim +*> +*> \param[out] ND +*> \verbatim +*> ND is INTEGER +*> On exit, the number of nodes on the tree. +*> \endverbatim +*> +*> \param[out] INODE +*> \verbatim +*> INODE is INTEGER array, dimension ( N ) +*> On exit, centers of subproblems. +*> \endverbatim +*> +*> \param[out] NDIML +*> \verbatim +*> NDIML is INTEGER array, dimension ( N ) +*> On exit, row dimensions of left children. +*> \endverbatim +*> +*> \param[out] NDIMR +*> \verbatim +*> NDIMR is INTEGER array, dimension ( N ) +*> On exit, row dimensions of right children. +*> \endverbatim +*> +*> \param[in] MSUB +*> \verbatim +*> MSUB is INTEGER +*> On entry, the maximum row dimension each subproblem at the +*> bottom of the tree can be of. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER LVL, MSUB, N, ND +* .. +* .. Array Arguments .. + INTEGER INODE( * ), NDIML( * ), NDIMR( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IL, IR, LLST, MAXN, NCRNT, NLVL + DOUBLE PRECISION TEMP +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, LOG, MAX +* .. +* .. Executable Statements .. +* +* Find the number of levels on the tree. +* + MAXN = MAX( 1, N ) + TEMP = LOG( DBLE( MAXN ) / DBLE( MSUB+1 ) ) / LOG( TWO ) + LVL = INT( TEMP ) + 1 +* + I = N / 2 + INODE( 1 ) = I + 1 + NDIML( 1 ) = I + NDIMR( 1 ) = N - I - 1 + IL = 0 + IR = 1 + LLST = 1 + DO 20 NLVL = 1, LVL - 1 +* +* Constructing the tree at (NLVL+1)-st level. The number of +* nodes created on this level is LLST * 2. +* + DO 10 I = 0, LLST - 1 + IL = IL + 2 + IR = IR + 2 + NCRNT = LLST + I + NDIML( IL ) = NDIML( NCRNT ) / 2 + NDIMR( IL ) = NDIML( NCRNT ) - NDIML( IL ) - 1 + INODE( IL ) = INODE( NCRNT ) - NDIMR( IL ) - 1 + NDIML( IR ) = NDIMR( NCRNT ) / 2 + NDIMR( IR ) = NDIMR( NCRNT ) - NDIML( IR ) - 1 + INODE( IR ) = INODE( NCRNT ) + NDIML( IR ) + 1 + 10 CONTINUE + LLST = LLST*2 + 20 CONTINUE + ND = LLST*2 - 1 +* + RETURN +* +* End of DLASDT +* + END diff --git a/math/lapack/src/main/fortran/dlaset.f b/math/lapack/src/main/fortran/dlaset.f new file mode 100644 index 0000000000..3a0c469a3c --- /dev/null +++ b/math/lapack/src/main/fortran/dlaset.f @@ -0,0 +1,184 @@ +*> \brief \b DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASET + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, M, N +* DOUBLE PRECISION ALPHA, BETA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASET initializes an m-by-n matrix A to BETA on the diagonal and +*> ALPHA on the offdiagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is 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. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> The constant to which the offdiagonal elements are to be set. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION +*> The constant to which the diagonal elements are to be set. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is 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). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, M, N + DOUBLE PRECISION ALPHA, BETA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlasq1.f b/math/lapack/src/main/fortran/dlasq1.f new file mode 100644 index 0000000000..468676eebd --- /dev/null +++ b/math/lapack/src/main/fortran/dlasq1.f @@ -0,0 +1,224 @@ +*> \brief \b DLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASQ1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns in the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is 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. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is 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. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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 100*N +*> iterations (in inner while loop) On exit D and E +*> represent a matrix with the same singular values +*> which the calling subroutine could use to finish the +*> computation, or even feed back into DLASQ1 +*> = 3, termination criterion of outer while loop not met +*> (program created more than N unreduced blocks) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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 = -1 + 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 ) + ELSE IF( INFO.EQ.2 ) THEN +* +* Maximum number of iterations exceeded. Move data from WORK +* into D and E so the calling subroutine can try to finish +* + DO I = 1, N + D( I ) = SQRT( WORK( 2*I-1 ) ) + E( I ) = SQRT( WORK( 2*I ) ) + END DO + CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO ) + CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, E, N, IINFO ) + END IF +* + RETURN +* +* End of DLASQ1 +* + END diff --git a/math/lapack/src/main/fortran/dlasq2.f b/math/lapack/src/main/fortran/dlasq2.f new file mode 100644 index 0000000000..68d9228704 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasq2.f @@ -0,0 +1,582 @@ +*> \brief \b DLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix associated with the qd Array Z to high relative accuracy. Used by sbdsqr and sstegr. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASQ2( N, Z, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASQ2 computes all the eigenvalues of the symmetric positive +*> definite tridiagonal matrix associated with the qd array Z to high +*> relative accuracy are computed to high relative accuracy, in the +*> absence of denormalization, underflow and overflow. +*> +*> To see the relation of Z to the tridiagonal matrix, let L be a +*> unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and +*> let U be an upper bidiagonal matrix with 1's above and diagonal +*> Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the +*> symmetric tridiagonal to which it is similar. +*> +*> Note : DLASQ2 defines a logical variable, IEEE, which is true +*> on machines which follow ieee-754 floating-point standard in their +*> handling of infinities and NaNs, and false otherwise. This variable +*> is passed to DLASQ3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns in the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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 100*N +*> iterations (in inner while loop). On exit Z holds +*> a qd array with the same eigenvalues as the given Z. +*> = 3, termination criterion of outer while loop not met +*> (program created more than N unreduced blocks) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLASQ2( N, Z, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* ===================================================================== +* +* .. 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, I1, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, + $ K, KMIN, N0, N1, NBIG, NDIV, NFAIL, PP, SPLT, + $ TTYPE + DOUBLE PRECISION D, DEE, DEEMIN, DESIG, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, E, EMAX, EMIN, EPS, G, OLDEMN, QMAX, + $ QMIN, S, SAFMIN, SIGMA, T, TAU, TEMP, TOL, + $ TOL2, TRACE, ZMAX, TEMPE, TEMPQ +* .. +* .. External Subroutines .. + EXTERNAL DLASQ3, 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 DLASQ3. +* + TTYPE = 0 + DMIN1 = ZERO + DMIN2 = ZERO + DN = ZERO + DN1 = ZERO + DN2 = ZERO + G = ZERO + TAU = ZERO +* + ITER = 2 + NFAIL = 0 + NDIV = 2*( N0-I0 ) +* + DO 160 IWHILA = 1, N + 1 + IF( N0.LT.1 ) + $ GO TO 170 +* +* 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 + PP = 0 +* + IF( N0-I0.GT.1 ) THEN + DEE = Z( 4*I0-3 ) + DEEMIN = DEE + KMIN = I0 + DO 110 I4 = 4*I0+1, 4*N0-3, 4 + DEE = Z( I4 )*( DEE /( DEE+Z( I4-2 ) ) ) + IF( DEE.LE.DEEMIN ) THEN + DEEMIN = DEE + KMIN = ( I4+3 )/4 + END IF + 110 CONTINUE + IF( (KMIN-I0)*2.LT.N0-KMIN .AND. + $ DEEMIN.LE.HALF*Z(4*N0-3) ) THEN + IPN4 = 4*( I0+N0 ) + PP = 2 + DO 120 I4 = 4*I0, 2*( I0+N0-1 ), 4 + TEMP = Z( I4-3 ) + Z( I4-3 ) = Z( IPN4-I4-3 ) + Z( IPN4-I4-3 ) = TEMP + TEMP = Z( I4-2 ) + Z( I4-2 ) = Z( IPN4-I4-2 ) + Z( IPN4-I4-2 ) = TEMP + TEMP = Z( I4-1 ) + Z( I4-1 ) = Z( IPN4-I4-5 ) + Z( IPN4-I4-5 ) = TEMP + TEMP = Z( I4 ) + Z( I4 ) = Z( IPN4-I4-4 ) + Z( IPN4-I4-4 ) = TEMP + 120 CONTINUE + END IF + END IF +* +* Put -(initial shift) into DMIN. +* + DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) ) +* +* Now I0:N0 is unreduced. +* PP = 0 for ping, PP = 1 for pong. +* PP = 2 indicates that flipping was applied to the Z array and +* and that the tests for deflation upon entry in DLASQ3 +* should not be performed. +* + NBIG = 100*( N0-I0+1 ) + DO 140 IWHILB = 1, NBIG + IF( I0.GT.N0 ) + $ GO TO 150 +* +* While submatrix unfinished take a good dqds step. +* + CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, + $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, + $ DN2, G, TAU ) +* + PP = 1 - PP +* +* When EMIN is very small check for splits. +* + IF( PP.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 130 I4 = 4*I0, 4*( N0-3 ), 4 + IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR. + $ Z( I4-1 ).LE.TOL2*SIGMA ) THEN + Z( I4-1 ) = -SIGMA + 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 + 130 CONTINUE + Z( 4*N0-1 ) = EMIN + Z( 4*N0 ) = OLDEMN + I0 = SPLT + 1 + END IF + END IF +* + 140 CONTINUE +* + INFO = 2 +* +* Maximum number of iterations exceeded, restore the shift +* SIGMA and place the new d's and e's in a qd array. +* This might need to be done for several blocks +* + I1 = I0 + N1 = N0 + 145 CONTINUE + TEMPQ = Z( 4*I0-3 ) + Z( 4*I0-3 ) = Z( 4*I0-3 ) + SIGMA + DO K = I0+1, N0 + TEMPE = Z( 4*K-5 ) + Z( 4*K-5 ) = Z( 4*K-5 ) * (TEMPQ / Z( 4*K-7 )) + TEMPQ = Z( 4*K-3 ) + Z( 4*K-3 ) = Z( 4*K-3 ) + SIGMA + TEMPE - Z( 4*K-5 ) + END DO +* +* Prepare to do this on the previous block if there is one +* + IF( I1.GT.1 ) THEN + N1 = I1-1 + DO WHILE( ( I1.GE.2 ) .AND. ( Z(4*I1-5).GE.ZERO ) ) + I1 = I1 - 1 + END DO + SIGMA = -Z(4*N1-1) + GO TO 145 + END IF + + DO K = 1, N + Z( 2*K-1 ) = Z( 4*K-3 ) +* +* Only the block 1..N0 is unfinished. The rest of the e's +* must be essentially zero, although sometimes other data +* has been stored in them. +* + IF( K.LT.N0 ) THEN + Z( 2*K ) = Z( 4*K-1 ) + ELSE + Z( 2*K ) = 0 + END IF + END DO + RETURN +* +* end IWHILB +* + 150 CONTINUE +* + 160 CONTINUE +* + INFO = 3 + RETURN +* +* end IWHILA +* + 170 CONTINUE +* +* Move q's to the front. +* + DO 180 K = 2, N + Z( K ) = Z( 4*K-3 ) + 180 CONTINUE +* +* Sort and compute sum of eigenvalues. +* + CALL DLASRT( 'D', N, Z, IINFO ) +* + E = ZERO + DO 190 K = N, 1, -1 + E = E + Z( K ) + 190 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/math/lapack/src/main/fortran/dlasq3.f b/math/lapack/src/main/fortran/dlasq3.f new file mode 100644 index 0000000000..c095bdbbb5 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasq3.f @@ -0,0 +1,421 @@ +*> \brief \b DLASQ3 checks for deflation, computes a shift and calls dqds. Used by sbdsqr. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASQ3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, +* ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, +* DN2, G, TAU ) +* +* .. Scalar Arguments .. +* LOGICAL IEEE +* INTEGER I0, ITER, N0, NDIV, NFAIL, PP +* DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, +* $ QMAX, SIGMA, TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] I0 +*> \verbatim +*> I0 is INTEGER +*> First index. +*> \endverbatim +*> +*> \param[in,out] N0 +*> \verbatim +*> N0 is INTEGER +*> Last index. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( 4*N0 ) +*> Z holds the qd array. +*> \endverbatim +*> +*> \param[in,out] PP +*> \verbatim +*> PP is INTEGER +*> PP=0 for ping, PP=1 for pong. +*> PP=2 indicates that flipping was applied to the Z array +*> and that the initial tests for deflation should not be +*> performed. +*> \endverbatim +*> +*> \param[out] DMIN +*> \verbatim +*> DMIN is DOUBLE PRECISION +*> Minimum value of d. +*> \endverbatim +*> +*> \param[out] SIGMA +*> \verbatim +*> SIGMA is DOUBLE PRECISION +*> Sum of shifts used in current segment. +*> \endverbatim +*> +*> \param[in,out] DESIG +*> \verbatim +*> DESIG is DOUBLE PRECISION +*> Lower order part of SIGMA +*> \endverbatim +*> +*> \param[in] QMAX +*> \verbatim +*> QMAX is DOUBLE PRECISION +*> Maximum value of q. +*> \endverbatim +*> +*> \param[in,out] NFAIL +*> \verbatim +*> NFAIL is INTEGER +*> Increment NFAIL by 1 each time the shift was too big. +*> \endverbatim +*> +*> \param[in,out] ITER +*> \verbatim +*> ITER is INTEGER +*> Increment ITER by 1 for each iteration. +*> \endverbatim +*> +*> \param[in,out] NDIV +*> \verbatim +*> NDIV is INTEGER +*> Increment NDIV by 1 for each division. +*> \endverbatim +*> +*> \param[in] IEEE +*> \verbatim +*> IEEE is LOGICAL +*> Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). +*> \endverbatim +*> +*> \param[in,out] TTYPE +*> \verbatim +*> TTYPE is INTEGER +*> Shift type. +*> \endverbatim +*> +*> \param[in,out] DMIN1 +*> \verbatim +*> DMIN1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] DMIN2 +*> \verbatim +*> DMIN2 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] DN +*> \verbatim +*> DN is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] DN1 +*> \verbatim +*> DN1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] DN2 +*> \verbatim +*> DN2 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] G +*> \verbatim +*> G is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> +*> These are passed as arguments in order to save their values +*> between calls to DLASQ3. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, + $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, + $ DN2, G, TAU ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER I0, ITER, N0, NDIV, NFAIL, PP + DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, + $ QMAX, SIGMA, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* ===================================================================== +* +* .. 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 EPS, S, T, TEMP, TOL, TOL2 +* .. +* .. External Subroutines .. + EXTERNAL DLASQ4, DLASQ5, DLASQ6 +* .. +* .. External Function .. + DOUBLE PRECISION DLAMCH + LOGICAL DISNAN + EXTERNAL DISNAN, DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + N0IN = N0 + EPS = DLAMCH( 'Precision' ) + 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 + T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) ) + IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2.AND.T.NE.ZERO ) THEN + 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 + IF( PP.EQ.2 ) + $ PP = 0 +* +* 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 +* +* Choose a shift. +* + CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, + $ DN2, TAU, TTYPE, G ) +* +* Call dqds until DMIN > 0. +* + 70 CONTINUE +* + CALL DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, IEEE, EPS ) +* + NDIV = NDIV + ( N0-I0+2 ) + ITER = ITER + 1 +* +* Check status. +* + IF( DMIN.GE.ZERO .AND. DMIN1.GE.ZERO ) THEN +* +* Success. +* + GO TO 90 +* + ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. + $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. + $ ABS( DN ).LT.TOL*SIGMA ) THEN +* +* Convergence hidden by negative DN. +* + Z( 4*( N0-1 )-PP+2 ) = ZERO + DMIN = ZERO + GO TO 90 + ELSE IF( DMIN.LT.ZERO ) THEN +* +* TAU too big. Select new TAU and try again. +* + 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 70 + ELSE IF( DISNAN( DMIN ) ) THEN +* +* NaN. +* + IF( TAU.EQ.ZERO ) THEN + GO TO 80 + ELSE + TAU = ZERO + GO TO 70 + END IF + ELSE +* +* Possible underflow. Play it safe. +* + GO TO 80 + END IF +* +* Risk of underflow. +* + 80 CONTINUE + CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) + NDIV = NDIV + ( N0-I0+2 ) + ITER = ITER + 1 + TAU = ZERO +* + 90 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/math/lapack/src/main/fortran/dlasq4.f b/math/lapack/src/main/fortran/dlasq4.f new file mode 100644 index 0000000000..cb7a714cc6 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasq4.f @@ -0,0 +1,425 @@ +*> \brief \b DLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous transform. Used by sbdsqr. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASQ4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, +* DN1, DN2, TAU, TTYPE, G ) +* +* .. Scalar Arguments .. +* INTEGER I0, N0, N0IN, PP, TTYPE +* DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASQ4 computes an approximation TAU to the smallest eigenvalue +*> using values of d from the previous transform. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] I0 +*> \verbatim +*> I0 is INTEGER +*> First index. +*> \endverbatim +*> +*> \param[in] N0 +*> \verbatim +*> N0 is INTEGER +*> Last index. +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( 4*N0 ) +*> Z holds the qd array. +*> \endverbatim +*> +*> \param[in] PP +*> \verbatim +*> PP is INTEGER +*> PP=0 for ping, PP=1 for pong. +*> \endverbatim +*> +*> \param[in] N0IN +*> \verbatim +*> N0IN is INTEGER +*> The value of N0 at start of EIGTEST. +*> \endverbatim +*> +*> \param[in] DMIN +*> \verbatim +*> DMIN is DOUBLE PRECISION +*> Minimum value of d. +*> \endverbatim +*> +*> \param[in] DMIN1 +*> \verbatim +*> DMIN1 is DOUBLE PRECISION +*> Minimum value of d, excluding D( N0 ). +*> \endverbatim +*> +*> \param[in] DMIN2 +*> \verbatim +*> DMIN2 is DOUBLE PRECISION +*> Minimum value of d, excluding D( N0 ) and D( N0-1 ). +*> \endverbatim +*> +*> \param[in] DN +*> \verbatim +*> DN is DOUBLE PRECISION +*> d(N) +*> \endverbatim +*> +*> \param[in] DN1 +*> \verbatim +*> DN1 is DOUBLE PRECISION +*> d(N-1) +*> \endverbatim +*> +*> \param[in] DN2 +*> \verbatim +*> DN2 is DOUBLE PRECISION +*> d(N-2) +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> This is the shift. +*> \endverbatim +*> +*> \param[out] TTYPE +*> \verbatim +*> TTYPE is INTEGER +*> Shift type. +*> \endverbatim +*> +*> \param[in,out] G +*> \verbatim +*> G is DOUBLE PRECISION +*> G is passed as an argument in order to save its value between +*> calls to DLASQ4. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup auxOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> CNST1 = 9/16 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, TAU, TTYPE, G ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER I0, N0, N0IN, PP, TTYPE + DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* ===================================================================== +* +* .. 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 DLASQ4 +* + END diff --git a/math/lapack/src/main/fortran/dlasq5.f b/math/lapack/src/main/fortran/dlasq5.f new file mode 100644 index 0000000000..99d4f678eb --- /dev/null +++ b/math/lapack/src/main/fortran/dlasq5.f @@ -0,0 +1,410 @@ +*> \brief \b DLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASQ5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN, +* DNM1, DNM2, IEEE, EPS ) +* +* .. Scalar Arguments .. +* LOGICAL IEEE +* INTEGER I0, N0, PP +* DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU, SIGMA, EPS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASQ5 computes one dqds transform in ping-pong form, one +*> version for IEEE machines another for non IEEE machines. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] I0 +*> \verbatim +*> I0 is INTEGER +*> First index. +*> \endverbatim +*> +*> \param[in] N0 +*> \verbatim +*> N0 is INTEGER +*> Last index. +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( 4*N ) +*> Z holds the qd array. EMIN is stored in Z(4*N0) to avoid +*> an extra argument. +*> \endverbatim +*> +*> \param[in] PP +*> \verbatim +*> PP is INTEGER +*> PP=0 for ping, PP=1 for pong. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> This is the shift. +*> \endverbatim +*> +*> \param[in] SIGMA +*> \verbatim +*> SIGMA is DOUBLE PRECISION +*> This is the accumulated shift up to this step. +*> \endverbatim +*> +*> \param[out] DMIN +*> \verbatim +*> DMIN is DOUBLE PRECISION +*> Minimum value of d. +*> \endverbatim +*> +*> \param[out] DMIN1 +*> \verbatim +*> DMIN1 is DOUBLE PRECISION +*> Minimum value of d, excluding D( N0 ). +*> \endverbatim +*> +*> \param[out] DMIN2 +*> \verbatim +*> DMIN2 is DOUBLE PRECISION +*> Minimum value of d, excluding D( N0 ) and D( N0-1 ). +*> \endverbatim +*> +*> \param[out] DN +*> \verbatim +*> DN is DOUBLE PRECISION +*> d(N0), the last value of d. +*> \endverbatim +*> +*> \param[out] DNM1 +*> \verbatim +*> DNM1 is DOUBLE PRECISION +*> d(N0-1). +*> \endverbatim +*> +*> \param[out] DNM2 +*> \verbatim +*> DNM2 is DOUBLE PRECISION +*> d(N0-2). +*> \endverbatim +*> +*> \param[in] IEEE +*> \verbatim +*> IEEE is LOGICAL +*> Flag for IEEE or non IEEE arithmetic. +*> \endverbatim +* +*> \param[in] EPS +*> \verbatim +*> EPS is DOUBLE PRECISION +*> This is the value of epsilon used. +*> \endverbatim +*> +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, + $ DN, DNM1, DNM2, IEEE, EPS ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER I0, N0, PP + DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU, + $ SIGMA, EPS +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameter .. + DOUBLE PRECISION ZERO, HALF + PARAMETER ( ZERO = 0.0D0, HALF = 0.5 ) +* .. +* .. Local Scalars .. + INTEGER J4, J4P2 + DOUBLE PRECISION D, EMIN, TEMP, DTHRESH +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( ( N0-I0-1 ).LE.0 ) + $ RETURN +* + DTHRESH = EPS*(SIGMA+TAU) + IF( TAU.LT.DTHRESH*HALF ) TAU = ZERO + IF( TAU.NE.ZERO ) THEN + 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 + ELSE +* This is the version that sets d's to zero if they are small enough + 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 50 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 + IF( D.LT.DTHRESH ) D = ZERO + DMIN = MIN( DMIN, D ) + Z( J4 ) = Z( J4-1 )*TEMP + EMIN = MIN( Z( J4 ), EMIN ) + 50 CONTINUE + ELSE + DO 60 J4 = 4*I0, 4*( N0-3 ), 4 + Z( J4-3 ) = D + Z( J4 ) + TEMP = Z( J4+2 ) / Z( J4-3 ) + D = D*TEMP - TAU + IF( D.LT.DTHRESH ) D = ZERO + DMIN = MIN( DMIN, D ) + Z( J4-1 ) = Z( J4 )*TEMP + EMIN = MIN( Z( J4-1 ), EMIN ) + 60 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 70 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 + IF( D.LT.DTHRESH) D = ZERO + DMIN = MIN( DMIN, D ) + EMIN = MIN( EMIN, Z( J4 ) ) + 70 CONTINUE + ELSE + DO 80 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 + IF( D.LT.DTHRESH) D = ZERO + DMIN = MIN( DMIN, D ) + EMIN = MIN( EMIN, Z( J4-1 ) ) + 80 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 + END IF +* + Z( J4+2 ) = DN + Z( 4*N0-PP ) = EMIN + RETURN +* +* End of DLASQ5 +* + END diff --git a/math/lapack/src/main/fortran/dlasq6.f b/math/lapack/src/main/fortran/dlasq6.f new file mode 100644 index 0000000000..d871386bdb --- /dev/null +++ b/math/lapack/src/main/fortran/dlasq6.f @@ -0,0 +1,254 @@ +*> \brief \b DLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASQ6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, +* DNM1, DNM2 ) +* +* .. Scalar Arguments .. +* INTEGER I0, N0, PP +* DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASQ6 computes one dqd (shift equal to zero) transform in +*> ping-pong form, with protection against underflow and overflow. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] I0 +*> \verbatim +*> I0 is INTEGER +*> First index. +*> \endverbatim +*> +*> \param[in] N0 +*> \verbatim +*> N0 is INTEGER +*> Last index. +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( 4*N ) +*> Z holds the qd array. EMIN is stored in Z(4*N0) to avoid +*> an extra argument. +*> \endverbatim +*> +*> \param[in] PP +*> \verbatim +*> PP is INTEGER +*> PP=0 for ping, PP=1 for pong. +*> \endverbatim +*> +*> \param[out] DMIN +*> \verbatim +*> DMIN is DOUBLE PRECISION +*> Minimum value of d. +*> \endverbatim +*> +*> \param[out] DMIN1 +*> \verbatim +*> DMIN1 is DOUBLE PRECISION +*> Minimum value of d, excluding D( N0 ). +*> \endverbatim +*> +*> \param[out] DMIN2 +*> \verbatim +*> DMIN2 is DOUBLE PRECISION +*> Minimum value of d, excluding D( N0 ) and D( N0-1 ). +*> \endverbatim +*> +*> \param[out] DN +*> \verbatim +*> DN is DOUBLE PRECISION +*> d(N0), the last value of d. +*> \endverbatim +*> +*> \param[out] DNM1 +*> \verbatim +*> DNM1 is DOUBLE PRECISION +*> d(N0-1). +*> \endverbatim +*> +*> \param[out] DNM2 +*> \verbatim +*> DNM2 is DOUBLE PRECISION +*> d(N0-2). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, + $ DNM1, DNM2 ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER I0, N0, PP + DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlasr.f b/math/lapack/src/main/fortran/dlasr.f new file mode 100644 index 0000000000..6059c6293a --- /dev/null +++ b/math/lapack/src/main/fortran/dlasr.f @@ -0,0 +1,436 @@ +*> \brief \b DLASR applies a sequence of plane rotations to a general rectangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) +* +* .. Scalar Arguments .. +* CHARACTER DIRECT, PIVOT, SIDE +* INTEGER LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is 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 +*> \endverbatim +*> +*> \param[in] PIVOT +*> \verbatim +*> PIVOT is 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) +*> \endverbatim +*> +*> \param[in] DIRECT +*> \verbatim +*> DIRECT is 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) +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. If m <= 1, an immediate +*> return is effected. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. If n <= 1, an +*> immediate return is effected. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension +*> (M-1) if SIDE = 'L' +*> (N-1) if SIDE = 'R' +*> The cosines c(k) of the plane rotations. +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is 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) ). +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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'. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, PIVOT, SIDE + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) +* .. +* +* ===================================================================== +* +* .. 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**T +* + 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/math/lapack/src/main/fortran/dlasrt.f b/math/lapack/src/main/fortran/dlasrt.f new file mode 100644 index 0000000000..4705311d78 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasrt.f @@ -0,0 +1,303 @@ +*> \brief \b DLASRT sorts numbers in increasing or decreasing order. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASRT( ID, N, D, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER ID +* INTEGER INFO, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ID +*> \verbatim +*> ID is CHARACTER*1 +*> = 'I': sort D in increasing order; +*> = 'D': sort D in decreasing order. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The length of the array D. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + SUBROUTINE DLASRT( ID, N, D, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER ID + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ) +* .. +* +* ===================================================================== +* +* .. 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 parameters. +* + 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/math/lapack/src/main/fortran/dlassq.f b/math/lapack/src/main/fortran/dlassq.f new file mode 100644 index 0000000000..885395e3c9 --- /dev/null +++ b/math/lapack/src/main/fortran/dlassq.f @@ -0,0 +1,155 @@ +*> \brief \b DLASSQ updates a sum of squares represented in scaled form. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASSQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) +* +* .. Scalar Arguments .. +* INTEGER INCX, N +* DOUBLE PRECISION SCALE, SUMSQ +* .. +* .. Array Arguments .. +* DOUBLE PRECISION X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of elements to be used from the vector X. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is 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. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The increment between successive values of the vector X. +*> INCX > 0. +*> \endverbatim +*> +*> \param[in,out] SCALE +*> \verbatim +*> SCALE is 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. +*> \endverbatim +*> +*> \param[in,out] SUMSQ +*> \verbatim +*> SUMSQ is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION SCALE, SUMSQ +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER IX + DOUBLE PRECISION ABSXI +* .. +* .. External Functions .. + LOGICAL DISNAN + EXTERNAL DISNAN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + IF( N.GT.0 ) THEN + DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX + ABSXI = ABS( X( IX ) ) + IF( ABSXI.GT.ZERO.OR.DISNAN( ABSXI ) ) THEN + 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/math/lapack/src/main/fortran/dlasv2.f b/math/lapack/src/main/fortran/dlasv2.f new file mode 100644 index 0000000000..9371d6d3b2 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasv2.f @@ -0,0 +1,325 @@ +*> \brief \b DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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 ]. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] F +*> \verbatim +*> F is DOUBLE PRECISION +*> The (1,1) element of the 2-by-2 matrix. +*> \endverbatim +*> +*> \param[in] G +*> \verbatim +*> G is DOUBLE PRECISION +*> The (1,2) element of the 2-by-2 matrix. +*> \endverbatim +*> +*> \param[in] H +*> \verbatim +*> H is DOUBLE PRECISION +*> The (2,2) element of the 2-by-2 matrix. +*> \endverbatim +*> +*> \param[out] SSMIN +*> \verbatim +*> SSMIN is DOUBLE PRECISION +*> abs(SSMIN) is the smaller singular value. +*> \endverbatim +*> +*> \param[out] SSMAX +*> \verbatim +*> SSMAX is DOUBLE PRECISION +*> abs(SSMAX) is the larger singular value. +*> \endverbatim +*> +*> \param[out] SNL +*> \verbatim +*> SNL is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] CSL +*> \verbatim +*> CSL is DOUBLE PRECISION +*> The vector (CSL, SNL) is a unit left singular vector for the +*> singular value abs(SSMAX). +*> \endverbatim +*> +*> \param[out] SNR +*> \verbatim +*> SNR is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] CSR +*> \verbatim +*> CSR is DOUBLE PRECISION +*> The vector (CSR, SNR) is a unit right singular vector for the +*> singular value abs(SSMAX). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlaswlq.f b/math/lapack/src/main/fortran/dlaswlq.f new file mode 100644 index 0000000000..2830711a68 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaswlq.f @@ -0,0 +1,258 @@ +* +* Definition: +* =========== +* +* SUBROUTINE DLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, +* LWORK, INFO) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASWLQ computes a blocked Short-Wide LQ factorization of a +*> M-by-N matrix A, where N >= M: +*> A = L * Q +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= M >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The row block size to be used in the blocked QR. +*> M >= MB >= 1 +*> \endverbatim +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> NB > M. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and bleow the diagonal +*> of the array contain the N-by-N lower triangular matrix L; +*> the elements above the diagonal represent Q by the rows +*> of blocked V (see Further Details). +*> +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, +*> dimension (LDT, N * Number_of_row_blocks) +*> where Number_of_row_blocks = CEIL((N-M)/(NB-M)) +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. +*> See Further Details below. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> +*> \endverbatim +*> \param[in] LWORK +*> \verbatim +*> The dimension of the array WORK. LWORK >= MB*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. +*> +*> \endverbatim +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A: +*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A +*> . . . +*> +*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GELQT. +*> +*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors +*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK, + $ INFO) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. -- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, MB, NB, LWORK, LDT +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ), T( LDT, *) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, II, KK, CTR +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DGELQT, DTPLQT, XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN, MOD +* .. +* .. 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.LT.M ) THEN + INFO = -2 + ELSE IF( MB.LT.1 .OR. ( MB.GT.M .AND. M.GT.0 )) THEN + INFO = -3 + ELSE IF( NB.LE.M ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDT.LT.MB ) THEN + INFO = -8 + ELSE IF( ( LWORK.LT.M*MB) .AND. (.NOT.LQUERY) ) THEN + INFO = -10 + END IF + IF( INFO.EQ.0) THEN + WORK(1) = MB*M + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASWLQ', -INFO ) + RETURN + ELSE IF (LQUERY) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N).EQ.0 ) THEN + RETURN + END IF +* +* The LQ Decomposition +* + IF((M.GE.N).OR.(NB.LE.M).OR.(NB.GE.N)) THEN + CALL DGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO) + RETURN + END IF +* + KK = MOD((N-M),(NB-M)) + II=N-KK+1 +* +* Compute the LQ factorization of the first block A(1:M,1:NB) +* + CALL DGELQT( M, NB, MB, A(1,1), LDA, T, LDT, WORK, INFO) + CTR = 1 +* + DO I = NB+1, II-NB+M , (NB-M) +* +* Compute the QR factorization of the current block A(1:M,I:I+NB-M) +* + CALL DTPLQT( M, NB-M, 0, MB, A(1,1), LDA, A( 1, I ), + $ LDA, T(1, CTR * M + 1), + $ LDT, WORK, INFO ) + CTR = CTR + 1 + END DO +* +* Compute the QR factorization of the last block A(1:M,II:N) +* + IF (II.LE.N) THEN + CALL DTPLQT( M, KK, 0, MB, A(1,1), LDA, A( 1, II ), + $ LDA, T(1, CTR * M + 1), LDT, + $ WORK, INFO ) + END IF +* + WORK( 1 ) = M * MB + RETURN +* +* End of DLASWLQ +* + END diff --git a/math/lapack/src/main/fortran/dlaswp.f b/math/lapack/src/main/fortran/dlaswp.f new file mode 100644 index 0000000000..2c526ffad1 --- /dev/null +++ b/math/lapack/src/main/fortran/dlaswp.f @@ -0,0 +1,191 @@ +*> \brief \b DLASWP performs a series of row interchanges on a general rectangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASWP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) +* +* .. Scalar Arguments .. +* INTEGER INCX, K1, K2, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> \endverbatim +*> +*> \param[in] K1 +*> \verbatim +*> K1 is INTEGER +*> The first element of IPIV for which a row interchange will +*> be done. +*> \endverbatim +*> +*> \param[in] K2 +*> \verbatim +*> K2 is INTEGER +*> (K2-K1+1) is the number of elements of IPIV for which a row +*> interchange will be done. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) +*> The vector of pivot indices. Only the elements in positions +*> K1 through K1+(K2-K1)*INCX of IPIV are accessed. +*> IPIV(K) = L implies rows K and L are to be interchanged. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The increment between successive values of IPIV. If IPIV +*> is negative, the pivots are applied in reverse order. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Modified by +*> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCX, K1, K2, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. 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 = K1 + ( K1-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/math/lapack/src/main/fortran/dlasy2.f b/math/lapack/src/main/fortran/dlasy2.f new file mode 100644 index 0000000000..2afad2be08 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasy2.f @@ -0,0 +1,482 @@ +*> \brief \b DLASY2 solves the Sylvester matrix equation where the matrices are of order 1 or 2. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASY2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, +* LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) +* +* .. 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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**T, where T**T denotes the transpose of T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] LTRANL +*> \verbatim +*> LTRANL is LOGICAL +*> On entry, LTRANL specifies the op(TL): +*> = .FALSE., op(TL) = TL, +*> = .TRUE., op(TL) = TL**T. +*> \endverbatim +*> +*> \param[in] LTRANR +*> \verbatim +*> LTRANR is LOGICAL +*> On entry, LTRANR specifies the op(TR): +*> = .FALSE., op(TR) = TR, +*> = .TRUE., op(TR) = TR**T. +*> \endverbatim +*> +*> \param[in] ISGN +*> \verbatim +*> ISGN is INTEGER +*> On entry, ISGN specifies the sign of the equation +*> as described before. ISGN may only be 1 or -1. +*> \endverbatim +*> +*> \param[in] N1 +*> \verbatim +*> N1 is INTEGER +*> On entry, N1 specifies the order of matrix TL. +*> N1 may only be 0, 1 or 2. +*> \endverbatim +*> +*> \param[in] N2 +*> \verbatim +*> N2 is INTEGER +*> On entry, N2 specifies the order of matrix TR. +*> N2 may only be 0, 1 or 2. +*> \endverbatim +*> +*> \param[in] TL +*> \verbatim +*> TL is DOUBLE PRECISION array, dimension (LDTL,2) +*> On entry, TL contains an N1 by N1 matrix. +*> \endverbatim +*> +*> \param[in] LDTL +*> \verbatim +*> LDTL is INTEGER +*> The leading dimension of the matrix TL. LDTL >= max(1,N1). +*> \endverbatim +*> +*> \param[in] TR +*> \verbatim +*> TR is DOUBLE PRECISION array, dimension (LDTR,2) +*> On entry, TR contains an N2 by N2 matrix. +*> \endverbatim +*> +*> \param[in] LDTR +*> \verbatim +*> LDTR is INTEGER +*> The leading dimension of the matrix TR. LDTR >= max(1,N2). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,2) +*> On entry, the N1 by N2 matrix B contains the right-hand +*> side of the equation. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the matrix B. LDB >= max(1,N1). +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION +*> On exit, SCALE contains the scale factor. SCALE is chosen +*> less than or equal to 1 to prevent the solution overflowing. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,2) +*> On exit, X contains the N1 by N2 solution. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the matrix X. LDX >= max(1,N1). +*> \endverbatim +*> +*> \param[out] XNORM +*> \verbatim +*> XNORM is DOUBLE PRECISION +*> On exit, XNORM is the infinity-norm of the solution. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleSYauxiliary +* +* ===================================================================== + SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, + $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. 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, * ) +* .. +* +* ===================================================================== +* +* .. 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 ) THEN + INFO = 1 + T16( 4, 4 ) = SMIN + END IF + 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/math/lapack/src/main/fortran/dlasyf.f b/math/lapack/src/main/fortran/dlasyf.f new file mode 100644 index 0000000000..de705e4ab0 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasyf.f @@ -0,0 +1,822 @@ +*> \brief \b DLASYF computes a partial factorization of a real symmetric matrix using the Bunch-Kaufman diagonal pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASYF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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**T U22**T ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in +*> the argument KB, and is either NB or NB-1, or N if N <= NB. +*> +*> DLASYF 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'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, A contains details of the partial factorization. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is 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 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 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': +*> Only the first KB elements of IPIV 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 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. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. Local Scalars .. + 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. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IDAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = ABS( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + 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 of W +* + 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 is the column of A where pivoting step stopped +* + KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* + KKW = NB + KK - N +* +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KKW of W. +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K-1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. +* + A( KP, KP ) = A( KK, KK ) + CALL DCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + IF( KP.GT.1 ) + $ CALL DCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* Interchange rows KK and KP in last K+1 to N columns of A +* (columns K (or K and K-1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in last KKW to NB columns of W. +* + IF( K.LT.N ) + $ CALL DSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), + $ 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(kw) = U(k)*D(k), +* +* where U(k) is the k-th column of U +* +* Store subdiag. elements of column U(k) +* and 1-by-1 block D(k) in column k of A. +* NOTE: Diagonal element U(k,k) is a UNIT element +* and not stored. +* A(k,k) := D(k,k) = W(k,kw) +* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) +* + 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(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 +* block D(k-1:k,k-1:k) in columns k-1 and k of A. +* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT +* block and not stored. +* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) +* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = +* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) +* + IF( K.GT.2 ) THEN +* +* Compose the columns of the inverse of 2-by-2 pivot +* block D in the following way to reduce the number +* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by +* this inverse +* +* D**(-1) = ( d11 d21 )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = +* ( (-d21 ) ( d11 ) ) +* +* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * +* +* * ( ( d22/d21 ) ( -1 ) ) = +* ( ( -1 ) ( d11/d21 ) ) +* +* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = 1/d21 * T * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) +* +* = D21 * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) +* + 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 +* +* Update elements in columns A(k-1) and A(k) as +* dot products of rows of ( W(kw-1) W(kw) ) and columns +* of D**(-1) +* + DO 20 J = 1, K - 2 + A( J, K-1 ) = 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**T = A11 - U12*W**T +* +* computing blocks of NB columns at a time +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = J, J + JB - 1 + CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, + $ A( J, JJ ), 1 ) + 40 CONTINUE +* +* Update the rectangular superdiagonal block +* + 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 looping backwards from k+1 to n +* + J = K + 1 + 60 CONTINUE +* +* Undo the interchanges (if any) of rows JJ and JP at each +* step J +* +* (Here, J is a diagonal index) + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + J = J + 1 + END IF +* (NOTE: Here, J is used to determine row length. Length N-J+1 +* of the rows to swap back doesn't include diagonal element) + 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.LT.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. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = ABS( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + 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 of W +* + 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 is the column of A where pivoting step stopped +* + KK = K + KSTEP - 1 +* +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KK of W. +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K+1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. +* + A( KP, KP ) = A( KK, KK ) + CALL DCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + IF( KP.LT.N ) + $ CALL DCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) +* +* Interchange rows KK and KP in first K-1 columns of A +* (columns K (or K and K+1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in first KK columns of W. +* + IF( K.GT.1 ) + $ CALL DSWAP( K-1, 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 subdiag. elements of column L(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element L(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,k) +* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) +* + 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 +* +* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 +* block D(k:k+1,k:k+1) in columns k and k+1 of A. +* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT +* block and not stored) +* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) +* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = +* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) +* + IF( K.LT.N-1 ) THEN +* +* Compose the columns of the inverse of 2-by-2 pivot +* block D in the following way to reduce the number +* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by +* this inverse +* +* D**(-1) = ( d11 d21 )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = +* ( (-d21 ) ( d11 ) ) +* +* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * +* +* * ( ( d22/d21 ) ( -1 ) ) = +* ( ( -1 ) ( d11/d21 ) ) +* +* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = 1/d21 * T * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) +* +* = D21 * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) +* + 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 +* +* Update elements in columns A(k) and A(k+1) as +* dot products of rows of ( W(k) W(k+1) ) and columns +* of D**(-1) +* + DO 80 J = K + 2, N + A( J, K ) = 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**T = A22 - L21*W**T +* +* computing blocks of NB columns at a time +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 1 + CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, + $ A( JJ, JJ ), 1 ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, + $ ONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Put L21 in standard form by partially undoing the interchanges +* of rows in columns 1:k-1 looping backwards from k-1 to 1 +* + J = K - 1 + 120 CONTINUE +* +* Undo the interchanges (if any) of rows JJ and JP at each +* step J +* +* (Here, J is a diagonal index) + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + J = J - 1 + END IF +* (NOTE: Here, J is used to determine row length. Length J +* of the rows to swap back doesn't include diagonal element) + J = J - 1 + IF( JP.NE.JJ .AND. J.GE.1 ) + $ CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) + IF( J.GT.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/math/lapack/src/main/fortran/dlasyf_aa.f b/math/lapack/src/main/fortran/dlasyf_aa.f new file mode 100644 index 0000000000..0bd2d6defa --- /dev/null +++ b/math/lapack/src/main/fortran/dlasyf_aa.f @@ -0,0 +1,506 @@ +*> \brief \b DLASYF_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASYF_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASYF_AA( UPLO, J1, M, NB, A, LDA, IPIV, +* H, LDH, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER J1, M, NB, LDA, LDH, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLATRF_AA factorizes a panel of a real symmetric matrix A using +*> the Aasen's algorithm. The panel consists of a set of NB rows of A +*> when UPLO is U, or a set of NB columns when UPLO is L. +*> +*> In order to factorize the panel, the Aasen's algorithm requires the +*> last row, or column, of the previous panel. The first row, or column, +*> of A is set to be the first row, or column, of an identity matrix, +*> which is used to factorize the first panel. +*> +*> The resulting J-th row of U, or J-th column of L, is stored in the +*> (J-1)-th row, or column, of A (without the unit diagonals), while +*> the diagonal and subdiagonal of A are overwritten by those of T. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] J1 +*> \verbatim +*> J1 is INTEGER +*> The location of the first row, or column, of the panel +*> within the submatrix of A, passed to this routine, e.g., +*> when called by DSYTRF_AA, for the first panel, J1 is 1, +*> while for the remaining panels, J1 is 2. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The dimension of the submatrix. M >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The dimension of the panel to be facotorized. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,M) for +*> the first panel, while dimension (LDA,M+1) for the +*> remaining panels. +*> +*> On entry, A contains the last row, or column, of +*> the previous panel, and the trailing submatrix of A +*> to be factorized, except for the first panel, only +*> the panel is passed. +*> +*> On exit, the leading panel is factorized. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the row and column interchanges, +*> the row and column k were interchanged with the row and +*> column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is DOUBLE PRECISION workspace, dimension (LDH,NB). +*> +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the workspace H. LDH >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION workspace, dimension (M). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DLASYF_AA( UPLO, J1, M, NB, A, LDA, IPIV, + $ H, LDH, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER M, NB, J1, LDA, LDH, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* +* .. Local Scalars .. + INTEGER J, K, K1, I1, I2 + DOUBLE PRECISION PIV, ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, ILAENV + EXTERNAL LSAME, ILAENV, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + J = 1 +* +* K1 is the first column of the panel to be factorized +* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks +* + K1 = (2-J1)+1 +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* ..................................................... +* Factorize A as U**T*D*U using the upper triangle of A +* ..................................................... +* + 10 CONTINUE + IF ( J.GT.MIN(M, NB) ) + $ GO TO 20 +* +* K is the column to be factorized +* when being called from DSYTRF_AA, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J, J:N) - H(J:N, 1:(J-1)) * L(J1:(J-1), J), +* where H(J:N, J) has been initialized to be A(J, J:N) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL DGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( 1, J ), 1, + $ ONE, H( J, J ), 1 ) + END IF +* +* Copy H(i:n, i) into WORK +* + CALL DCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J-1, J:N) * T(J-1,J), +* where A(J-1, J) stores T(J-1, J) and A(J-2, J:N) stores U(J-1, J:N) +* + ALPHA = -A( K-1, J ) + CALL DAXPY( M-J+1, ALPHA, A( K-2, J ), LDA, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( K, J ) = WORK( 1 ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L(J, (J+1):N) +* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N) +* + IF( K.GT.1 ) THEN + ALPHA = -A( K, J ) + CALL DAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = IDAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply symmetric pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1, I1+1:N) with A(I1+1:N, I2) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL DSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA, + $ A( J1+I1, I2 ), 1 ) +* +* Swap A(I1, I2+1:N) with A(I2, I2+1:N) +* + CALL DSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA, + $ A( J1+I2-1, I2+1 ), LDA ) +* +* Swap A(I1, I1) with A(I2,I2) +* + PIV = A( I1+J1-1, I1 ) + A( J1+I1-1, I1 ) = A( J1+I2-1, I2 ) + A( J1+I2-1, I2 ) = PIV +* +* Swap H(I1, 1:J1) with H(I2, 1:J1) +* + CALL DSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL DSWAP( I1-K1+1, A( 1, I1 ), 1, + $ A( 1, I2 ), 1 ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J, J+1) = T(J, J+1) +* + A( K, J+1 ) = WORK( 2 ) + IF( (A( K, J ).EQ.ZERO ) .AND. + $ ( (J.EQ.M) .OR. (A( K, J+1 ).EQ.ZERO))) THEN + IF(INFO .EQ. 0) THEN + INFO = J + ENDIF + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J:N, J), +* + CALL DCOPY( M-J, A( K+1, J+1 ), LDA, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( K, J+1 ).NE.ZERO ) THEN + ALPHA = ONE / A( K, J+1 ) + CALL DCOPY( M-J-1, WORK( 3 ), 1, A( K, J+2 ), LDA ) + CALL DSCAL( M-J-1, ALPHA, A( K, J+2 ), LDA ) + ELSE + CALL DLASET( 'Full', 1, M-J-1, ZERO, ZERO, + $ A( K, J+2 ), LDA) + END IF + ELSE + IF( (A( K, J ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 10 + 20 CONTINUE +* + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* + 30 CONTINUE + IF( J.GT.MIN( M, NB ) ) + $ GO TO 40 +* +* K is the column to be factorized +* when being called from DSYTRF_AA, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J:N, J) - H(J:N, 1:(J-1)) * L(J, J1:(J-1))^T, +* where H(J:N, J) has been initialized to be A(J:N, J) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL DGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( J, 1 ), LDA, + $ ONE, H( J, J ), 1 ) + END IF +* +* Copy H(J:N, J) into WORK +* + CALL DCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J:N, J-1) * T(J-1,J), +* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1) +* + ALPHA = -A( J, K-1 ) + CALL DAXPY( M-J+1, ALPHA, A( J, K-2 ), 1, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( J, K ) = WORK( 1 ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L((J+1):N, J) +* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J) +* + IF( K.GT.1 ) THEN + ALPHA = -A( J, K ) + CALL DAXPY( M-J, ALPHA, A( J+1, K-1 ), 1, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = IDAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply symmetric pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1+1:N, I1) with A(I2, I1+1:N) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL DSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1, + $ A( I2, J1+I1 ), LDA ) +* +* Swap A(I2+1:N, I1) with A(I2+1:N, I2) +* + CALL DSWAP( M-I2, A( I2+1, J1+I1-1 ), 1, + $ A( I2+1, J1+I2-1 ), 1 ) +* +* Swap A(I1, I1) with A(I2, I2) +* + PIV = A( I1, J1+I1-1 ) + A( I1, J1+I1-1 ) = A( I2, J1+I2-1 ) + A( I2, J1+I2-1 ) = PIV +* +* Swap H(I1, I1:J1) with H(I2, I2:J1) +* + CALL DSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL DSWAP( I1-K1+1, A( I1, 1 ), LDA, + $ A( I2, 1 ), LDA ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J+1, J) = T(J+1, J) +* + A( J+1, K ) = WORK( 2 ) + IF( (A( J, K ).EQ.ZERO) .AND. + $ ( (J.EQ.M) .OR. (A( J+1, K ).EQ.ZERO)) ) THEN + IF (INFO .EQ. 0) + $ INFO = J + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J+1:N, J), +* + CALL DCOPY( M-J, A( J+1, K+1 ), 1, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( J+1, K ).NE.ZERO ) THEN + ALPHA = ONE / A( J+1, K ) + CALL DCOPY( M-J-1, WORK( 3 ), 1, A( J+2, K ), 1 ) + CALL DSCAL( M-J-1, ALPHA, A( J+2, K ), 1 ) + ELSE + CALL DLASET( 'Full', M-J-1, 1, ZERO, ZERO, + $ A( J+2, K ), LDA ) + END IF + ELSE + IF( (A( J, K ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 30 + 40 CONTINUE + END IF + RETURN +* +* End of DLASYF_AA +* + END diff --git a/math/lapack/src/main/fortran/dlasyf_rk.f b/math/lapack/src/main/fortran/dlasyf_rk.f new file mode 100644 index 0000000000..209b4c89d1 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasyf_rk.f @@ -0,0 +1,965 @@ +*> \brief \b DLASYF_RK computes a partial factorization of a real symmetric indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASYF_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), E( * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DLASYF_RK computes a partial factorization of a real symmetric +*> matrix A using the bounded Bunch-Kaufman (rook) diagonal +*> pivoting method. The partial factorization has the form: +*> +*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: +*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L', +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in +*> the argument KB, and is either NB or NB-1, or N if N <= NB. +*> +*> DLASYF_RK is an auxiliary routine called by DSYTRF_RK. It uses +*> blocked code (calling Level 3 BLAS) to update the submatrix +*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the submatrix A(1:N,N-KB+1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,N-KB+1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the submatrix A(1:N,N-KB+1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b) is always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the submatrix A(1:N,1:KB). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the submatrix A(1:N,1:KB). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the submatrix A(1:N,1:KB). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b) is always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), E( * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, K, KK, KW, KKW, + $ KP, KSTEP, P, II + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, + $ DTEMP, R1, ROWMAX, T, SFMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IDAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = DLAMCH( 'S' ) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the trailing columns of A using the upper triangle +* of A and working backwards, and compute the matrix W = U12*D +* for use in updating A11 +* +* Initilize the first entry of array E, where superdiagonal +* elements of D are stored +* + E( 1 ) = ZERO +* +* K is the main loop index, decreasing from N in steps of 1 or 2 +* + K = N + 10 CONTINUE +* +* KW is the column of W which corresponds to column K of A +* + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) + $ GO TO 30 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column KW of W and update it +* + CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) + IF( K.LT.N ) + $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), + $ LDA, W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( W( K, KW ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IDAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = ABS( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) +* +* Set E( K ) to zero +* + IF( K.GT.1 ) + $ E( K ) = ZERO +* + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column KW-1 of W and update it +* + CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) + CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, + $ W( IMAX+1, KW-1 ), 1 ) +* + IF( K.LT.N ) + $ CALL DGEMV( 'No transpose', K, N-K, -ONE, + $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW, + $ ONE, W( 1, KW-1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), + $ 1 ) + ROWMAX = ABS( W( JMAX, KW-1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 ) + DTEMP = ABS( W( ITEMP, KW-1 ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.(ABS( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column KW-1 of W to column KW of W +* + CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* ============================================================ +* + KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* + KKW = NB + KK - N +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL DCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA ) + CALL DCOPY( P, A( 1, K ), 1, A( 1, P ), 1 ) +* +* Interchange rows K and P in last N-K+1 columns of A +* and last N-K+2 columns of W +* + CALL DSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA ) + CALL DSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW ) + END IF +* +* Updated column KP is already stored in column KKW of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* Interchange rows KK and KP in last N-KK+1 columns +* of A and W +* + CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) + CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), + $ LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column KW of W now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* +* Store U(k) in column k of A +* + CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + IF( K.GT.1 ) THEN + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN + R1 = ONE / A( K, K ) + CALL DSCAL( K-1, R1, A( 1, K ), 1 ) + ELSE IF( A( K, K ).NE.ZERO ) THEN + DO 14 II = 1, K - 1 + A( II, K ) = A( II, K ) / A( K, K ) + 14 CONTINUE + END IF +* +* Store the superdiagonal element of D in array E +* + E( K ) = ZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns KW and KW-1 of W now +* hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* + IF( K.GT.2 ) THEN +* +* Store U(k) and U(k-1) in columns k and k-1 of A +* + D12 = W( K-1, KW ) + D11 = W( K, KW ) / D12 + D22 = W( K-1, KW-1 ) / D12 + T = ONE / ( D11*D22-ONE ) + DO 20 J = 1, K - 2 + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D12 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D12 ) + 20 CONTINUE + END IF +* +* Copy diagonal elements of D(K) to A, +* copy superdiagonal element of D(K) to E(K) and +* ZERO out superdiagonal entry of A +* + A( K-1, K-1 ) = W( K-1, KW-1 ) + A( K-1, K ) = ZERO + A( K, K ) = W( K, KW ) + E( K ) = W( K-1, KW ) + E( K-1 ) = ZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 30 CONTINUE +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 - U12*D*U12**T = A11 - U12*W**T +* +* computing blocks of NB columns at a time +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = J, J + JB - 1 + CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, + $ A( J, JJ ), 1 ) + 40 CONTINUE +* +* Update the rectangular superdiagonal block +* + IF( J.GE.2 ) + $ CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, + $ N-K, -ONE, A( 1, K+1 ), LDA, W( J, KW+1 ), + $ LDW, ONE, A( 1, J ), LDA ) + 50 CONTINUE +* +* Set KB to the number of columns factorized +* + KB = N - K +* + ELSE +* +* Factorize the leading columns of A using the lower triangle +* of A and working forwards, and compute the matrix W = L21*D +* for use in updating A22 +* +* Initilize the unused last entry of the subdiagonal array E. +* + E( N ) = ZERO +* +* K is the main loop index, increasing from 1 in steps of 1 or 2 +* + K = 1 + 70 CONTINUE +* +* Exit from loop +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) + $ GO TO 90 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column K of W and update it +* + CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) + IF( K.GT.1 ) + $ CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), + $ LDA, W( K, 1 ), LDW, ONE, W( K, K ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( W( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = ABS( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) +* +* Set E( K ) to zero +* + IF( K.LT.N ) + $ E( K ) = ZERO +* + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 72 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column K+1 of W and update it +* + CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1) + CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, + $ W( IMAX, K+1 ), 1 ) + IF( K.GT.1 ) + $ CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, + $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW, + $ ONE, W( K, K+1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 ) + ROWMAX = ABS( W( JMAX, K+1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1) + DTEMP = ABS( W( ITEMP, K+1 ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column K+1 of W to column K of W +* + CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 72 +* + END IF +* +* ============================================================ +* + KK = K + KSTEP - 1 +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL DCOPY( P-K, A( K, K ), 1, A( P, K ), LDA ) + CALL DCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 ) +* +* Interchange rows K and P in first K columns of A +* and first K+1 columns of W +* + CALL DSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA ) + CALL DSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW ) + END IF +* +* Updated column KP is already stored in column KK of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) + CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) +* +* Interchange rows KK and KP in first KK columns of A and W +* + CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of W now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* +* Store L(k) in column k of A +* + CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + IF( K.LT.N ) THEN + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN + R1 = ONE / A( K, K ) + CALL DSCAL( N-K, R1, A( K+1, K ), 1 ) + ELSE IF( A( K, K ).NE.ZERO ) THEN + DO 74 II = K + 1, N + A( II, K ) = A( II, K ) / A( K, K ) + 74 CONTINUE + END IF +* +* Store the subdiagonal element of D in array E +* + E( K ) = ZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 of W now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* + IF( K.LT.N-1 ) THEN +* +* Store L(k) and L(k+1) in columns k and k+1 of A +* + D21 = W( K+1, K ) + D11 = W( K+1, K+1 ) / D21 + D22 = W( K, K ) / D21 + T = ONE / ( D11*D22-ONE ) + DO 80 J = K + 2, N + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) + 80 CONTINUE + END IF +* +* Copy diagonal elements of D(K) to A, +* copy subdiagonal element of D(K) to E(K) and +* ZERO out subdiagonal entry of A +* + A( K, K ) = W( K, K ) + A( K+1, K ) = ZERO + A( K+1, K+1 ) = W( K+1, K+1 ) + E( K ) = W( K+1, K ) + E( K+1 ) = ZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 70 +* + 90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 - L21*D*L21**T = A22 - L21*W**T +* +* computing blocks of NB columns at a time +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 1 + CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, + $ A( JJ, JJ ), 1 ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), + $ LDW, ONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Set KB to the number of columns factorized +* + KB = K - 1 +* + END IF +* + RETURN +* +* End of DLASYF_RK +* + END diff --git a/math/lapack/src/main/fortran/dlasyf_rook.f b/math/lapack/src/main/fortran/dlasyf_rook.f new file mode 100644 index 0000000000..49ee7a6c98 --- /dev/null +++ b/math/lapack/src/main/fortran/dlasyf_rook.f @@ -0,0 +1,892 @@ +*> \brief \b DLASYF_ROOK *> DLASYF_ROOK computes a partial factorization of a real symmetric matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASYF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) +* +* .. Scalar Arguments .. +* CHARADLATER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASYF_ROOK computes a partial factorization of a real symmetric +*> matrix A using the bounded Bunch-Kaufman ("rook") diagonal +*> pivoting method. The partial factorization has the form: +*> +*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: +*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in +*> the argument KB, and is either NB or NB-1, or N if N <= NB. +*> +*> DLASYF_ROOK is an auxiliary routine called by DSYTRF_ROOK. It uses +*> blocked code (calling Level 3 BLAS) to update the submatrix +*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, A contains details of the partial factorization. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is 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 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 IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV 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 IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, JP1, JP2, K, KK, + $ KW, KKW, KP, KSTEP, P, II + + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, + $ DTEMP, R1, ROWMAX, T, SFMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IDAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = DLAMCH( 'S' ) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the trailing columns of A using the upper triangle +* of A and working backwards, and compute the matrix W = U12*D +* for use in updating A11 +* +* K is the main loop index, decreasing from N in steps of 1 or 2 +* + K = N + 10 CONTINUE +* +* KW is the column of W which corresponds to column K of A +* + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) + $ GO TO 30 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column KW of W and update it +* + CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) + IF( K.LT.N ) + $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), + $ LDA, W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( W( K, KW ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IDAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = ABS( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column KW-1 of W and update it +* + CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) + CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, + $ W( IMAX+1, KW-1 ), 1 ) +* + IF( K.LT.N ) + $ CALL DGEMV( 'No transpose', K, N-K, -ONE, + $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW, + $ ONE, W( 1, KW-1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), + $ 1 ) + ROWMAX = ABS( W( JMAX, KW-1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 ) + DTEMP = ABS( W( ITEMP, KW-1 ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.(ABS( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column KW-1 of W to column KW of W +* + CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* ============================================================ +* + KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* + KKW = NB + KK - N +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL DCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA ) + CALL DCOPY( P, A( 1, K ), 1, A( 1, P ), 1 ) +* +* Interchange rows K and P in last N-K+1 columns of A +* and last N-K+2 columns of W +* + CALL DSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA ) + CALL DSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW ) + END IF +* +* Updated column KP is already stored in column KKW of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* Interchange rows KK and KP in last N-KK+1 columns +* of A and W +* + CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) + CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), + $ LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column KW of W now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* +* Store U(k) in column k of A +* + CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + IF( K.GT.1 ) THEN + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN + R1 = ONE / A( K, K ) + CALL DSCAL( K-1, R1, A( 1, K ), 1 ) + ELSE IF( A( K, K ).NE.ZERO ) THEN + DO 14 II = 1, K - 1 + A( II, K ) = A( II, K ) / A( K, K ) + 14 CONTINUE + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns KW and KW-1 of W now +* hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* + IF( K.GT.2 ) THEN +* +* Store U(k) and U(k-1) in columns k and k-1 of A +* + D12 = W( K-1, KW ) + D11 = W( K, KW ) / D12 + D22 = W( K-1, KW-1 ) / D12 + T = ONE / ( D11*D22-ONE ) + DO 20 J = 1, K - 2 + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D12 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D12 ) + 20 CONTINUE + END IF +* +* Copy 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 ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 30 CONTINUE +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 - U12*D*U12**T = A11 - U12*W**T +* +* computing blocks of NB columns at a time +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = J, J + JB - 1 + CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, + $ A( J, JJ ), 1 ) + 40 CONTINUE +* +* Update the rectangular superdiagonal block +* + IF( J.GE.2 ) + $ CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, + $ N-K, -ONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, + $ ONE, A( 1, J ), LDA ) + 50 CONTINUE +* +* Put U12 in standard form by partially undoing the interchanges +* in columns k+1:n +* + J = K + 1 + 60 CONTINUE +* + KSTEP = 1 + JP1 = 1 + JJ = J + JP2 = IPIV( J ) + IF( JP2.LT.0 ) THEN + JP2 = -JP2 + J = J + 1 + JP1 = -IPIV( J ) + KSTEP = 2 + END IF +* + J = J + 1 + IF( JP2.NE.JJ .AND. J.LE.N ) + $ CALL DSWAP( N-J+1, A( JP2, J ), LDA, A( JJ, J ), LDA ) + JJ = J - 1 + IF( JP1.NE.JJ .AND. KSTEP.EQ.2 ) + $ CALL DSWAP( N-J+1, A( JP1, 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 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column K of W and update it +* + CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) + IF( K.GT.1 ) + $ CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), + $ LDA, W( K, 1 ), LDW, ONE, W( K, K ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( W( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = ABS( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 72 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column K+1 of W and update it +* + CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1) + CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, + $ W( IMAX, K+1 ), 1 ) + IF( K.GT.1 ) + $ CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, + $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW, + $ ONE, W( K, K+1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 ) + ROWMAX = ABS( W( JMAX, K+1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1) + DTEMP = ABS( W( ITEMP, K+1 ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column K+1 of W to column K of W +* + CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 72 +* + END IF +* +* ============================================================ +* + KK = K + KSTEP - 1 +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL DCOPY( P-K, A( K, K ), 1, A( P, K ), LDA ) + CALL DCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 ) +* +* Interchange rows K and P in first K columns of A +* and first K+1 columns of W +* + CALL DSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA ) + CALL DSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW ) + END IF +* +* Updated column KP is already stored in column KK of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) + CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) +* +* Interchange rows KK and KP in first KK columns of A and W +* + CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of W now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* +* Store L(k) in column k of A +* + CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + IF( K.LT.N ) THEN + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN + R1 = ONE / A( K, K ) + CALL DSCAL( N-K, R1, A( K+1, K ), 1 ) + ELSE IF( A( K, K ).NE.ZERO ) THEN + DO 74 II = K + 1, N + A( II, K ) = A( II, K ) / A( K, K ) + 74 CONTINUE + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 of W now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* + IF( K.LT.N-1 ) THEN +* +* Store L(k) and L(k+1) in columns k and k+1 of A +* + D21 = W( K+1, K ) + D11 = W( K+1, K+1 ) / D21 + D22 = W( K, K ) / D21 + T = ONE / ( D11*D22-ONE ) + DO 80 J = K + 2, N + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) + 80 CONTINUE + END IF +* +* Copy 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 ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 70 +* + 90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 - L21*D*L21**T = A22 - L21*W**T +* +* computing blocks of NB columns at a time +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 1 + CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, + $ A( JJ, JJ ), 1 ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, + $ ONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Put L21 in standard form by partially undoing the interchanges +* in columns 1:k-1 +* + J = K - 1 + 120 CONTINUE +* + KSTEP = 1 + JP1 = 1 + JJ = J + JP2 = IPIV( J ) + IF( JP2.LT.0 ) THEN + JP2 = -JP2 + J = J - 1 + JP1 = -IPIV( J ) + KSTEP = 2 + END IF +* + J = J - 1 + IF( JP2.NE.JJ .AND. J.GE.1 ) + $ CALL DSWAP( J, A( JP2, 1 ), LDA, A( JJ, 1 ), LDA ) + JJ = J + 1 + IF( JP1.NE.JJ .AND. KSTEP.EQ.2 ) + $ CALL DSWAP( J, A( JP1, 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_ROOK +* + END diff --git a/math/lapack/src/main/fortran/dlat2s.f b/math/lapack/src/main/fortran/dlat2s.f new file mode 100644 index 0000000000..fa6cc5d57b --- /dev/null +++ b/math/lapack/src/main/fortran/dlat2s.f @@ -0,0 +1,173 @@ +*> \brief \b DLAT2S converts a double-precision triangular matrix to a single-precision triangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAT2S + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAT2S( UPLO, N, A, LDA, SA, LDSA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDSA, N +* .. +* .. Array Arguments .. +* REAL SA( LDSA, * ) +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAT2S converts a DOUBLE PRECISION triangular matrix, SA, to a SINGLE +*> PRECISION triangular matrix, A. +*> +*> RMAX is the overflow for the SINGLE PRECISION arithmetic +*> DLAS2S checks that all the entries of A are between -RMAX and +*> RMAX. If not the conversion is aborted and a flag is raised. +*> +*> This is an auxiliary routine so there is no argument checking. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the N-by-N triangular coefficient matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] SA +*> \verbatim +*> SA is REAL array, dimension (LDSA,N) +*> Only the UPLO part of SA is referenced. On exit, if INFO=0, +*> the N-by-N coefficient matrix SA; if INFO>0, the content of +*> the UPLO part of SA is unspecified. +*> \endverbatim +*> +*> \param[in] LDSA +*> \verbatim +*> LDSA is INTEGER +*> The leading dimension of the array SA. LDSA >= max(1,M). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> = 1: an entry of the matrix A is greater than the SINGLE +*> PRECISION overflow threshold, in this case, the content +*> of the UPLO part of SA in exit is unspecified. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAT2S( UPLO, N, A, LDA, SA, LDSA, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDSA, N +* .. +* .. Array Arguments .. + REAL SA( LDSA, * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION RMAX + LOGICAL UPPER +* .. +* .. External Functions .. + REAL SLAMCH + LOGICAL LSAME + EXTERNAL SLAMCH, LSAME +* .. +* .. Executable Statements .. +* + RMAX = SLAMCH( 'O' ) + UPPER = LSAME( UPLO, 'U' ) + IF( UPPER ) THEN + DO 20 J = 1, N + DO 10 I = 1, J + IF( ( A( I, J ).LT.-RMAX ) .OR. ( A( I, J ).GT.RMAX ) ) + $ THEN + INFO = 1 + GO TO 50 + END IF + SA( I, J ) = A( I, J ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J, N + IF( ( A( I, J ).LT.-RMAX ) .OR. ( A( I, J ).GT.RMAX ) ) + $ THEN + INFO = 1 + GO TO 50 + END IF + SA( I, J ) = A( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + 50 CONTINUE +* + RETURN +* +* End of DLAT2S +* + END diff --git a/math/lapack/src/main/fortran/dlatbs.f b/math/lapack/src/main/fortran/dlatbs.f new file mode 100644 index 0000000000..1489d53d06 --- /dev/null +++ b/math/lapack/src/main/fortran/dlatbs.f @@ -0,0 +1,812 @@ +*> \brief \b DLATBS solves a triangular banded system of equations. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLATBS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, +* SCALE, CNORM, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, NORMIN, TRANS, UPLO +* INTEGER INFO, KD, LDAB, N +* DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), CNORM( * ), X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLATBS solves one of the triangular systems +*> +*> A *x = s*b or A**T*x = s*b +*> +*> with scaling to prevent overflow, where A is an upper or lower +*> triangular band matrix. Here A**T denotes the transpose of A, x and b +*> are n-element vectors, and s is a scaling factor, usually less than +*> or equal to 1, chosen so that the components of x will be less than +*> the overflow threshold. If the unscaled problem will not cause +*> overflow, the Level 2 BLAS routine DTBSV is called. If the matrix A +*> is singular (A(j,j) = 0 for some j), then s is set to 0 and a +*> non-trivial solution to A*x = 0 is returned. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the matrix A is upper or lower triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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**T* x = s*b (Conjugate transpose = Transpose) +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the matrix A is unit triangular. +*> = 'N': Non-unit triangular +*> = 'U': Unit triangular +*> \endverbatim +*> +*> \param[in] NORMIN +*> \verbatim +*> NORMIN is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of subdiagonals or superdiagonals in the +*> triangular matrix A. KD >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> The upper or lower triangular band matrix A, stored in the +*> first KD+1 rows of the array. The j-th column of A is stored +*> in the j-th column of the array AB as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is 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. +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION +*> The scaling factor s for the triangular system +*> A * x = s*b or A**T* 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. +*> \endverbatim +*> +*> \param[in,out] CNORM +*> \verbatim +*> CNORM is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> A rough bound on x is computed; if that is less than overflow, DTBSV +*> is called, otherwise, specific code is used which checks for possible +*> overflow or divide-by-zero at every operation. +*> +*> A columnwise scheme is used for solving A*x = b. The basic algorithm +*> if A is lower triangular is +*> +*> x[1:n] := b[1:n] +*> for j = 1, ..., n +*> x(j) := x(j) / A(j,j) +*> x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] +*> end +*> +*> Define bounds on the components of x after j iterations of the loop: +*> M(j) = bound on x[1:j] +*> G(j) = bound on x[j+1:n] +*> Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. +*> +*> Then for iteration j+1 we have +*> M(j+1) <= G(j) / | A(j+1,j+1) | +*> G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | +*> <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) +*> +*> where CNORM(j+1) is greater than or equal to the infinity-norm of +*> column j+1 of A, not counting the diagonal. Hence +*> +*> G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) +*> 1<=i<=j +*> and +*> +*> |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) +*> 1<=i< j +*> +*> Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the +*> reciprocal of the largest M(j), j=1,..,n, is larger than +*> max(underflow, 1/overflow). +*> +*> The bound on x(j) is also used to determine when a step in the +*> columnwise method can be performed without fear of overflow. If +*> the computed bound is greater than a large constant, x is scaled to +*> prevent overflow, but if the bound overflows, x is set to 0, x(j) to +*> 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. +*> +*> Similarly, a row-wise scheme is used to solve A**T*x = b. The basic +*> algorithm for A upper triangular is +*> +*> for j = 1, ..., n +*> x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j) +*> end +*> +*> We simultaneously compute two bounds +*> G(j) = bound on ( b(i) - A[1:i-1,i]**T * x[1:i-1] ), 1<=i<=j +*> M(j) = bound on x(i), 1<=i<=j +*> +*> The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we +*> add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. +*> Then the bound on x(j) is +*> +*> M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | +*> +*> <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) +*> 1<=i<=j +*> +*> and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater +*> than max(underflow, 1/overflow). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, + $ SCALE, CNORM, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, NORMIN, TRANS, UPLO + INTEGER INFO, KD, LDAB, N + DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), CNORM( * ), X( * ) +* .. +* +* ===================================================================== +* +* .. 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, JLEN, MAIND + 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, DTBSV, 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( KD.LT.0 ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLATBS', -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 + JLEN = MIN( KD, J-1 ) + CNORM( J ) = DASUM( JLEN, AB( KD+1-JLEN, J ), 1 ) + 10 CONTINUE + ELSE +* +* A is lower triangular. +* + DO 20 J = 1, N + JLEN = MIN( KD, N-J ) + IF( JLEN.GT.0 ) THEN + CNORM( J ) = DASUM( JLEN, AB( 2, J ), 1 ) + ELSE + CNORM( J ) = ZERO + END IF + 20 CONTINUE + 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 DTBSV 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 + MAIND = KD + 1 + ELSE + JFIRST = 1 + JLAST = N + JINC = 1 + MAIND = 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( AB( MAIND, 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**T * x = b. +* + IF( UPPER ) THEN + JFIRST = 1 + JLAST = N + JINC = 1 + MAIND = KD + 1 + ELSE + JFIRST = N + JLAST = 1 + JINC = -1 + MAIND = 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( AB( MAIND, 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 DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, 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 = AB( MAIND, 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(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - +* x(j)* A(max(1,j-kd):j-1,j) +* + JLEN = MIN( KD, J-1 ) + CALL DAXPY( JLEN, -X( J )*TSCAL, + $ AB( KD+1-JLEN, J ), 1, X( J-JLEN ), 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:min(j+kd,n)) := x(j+1:min(j+kd,n)) - +* x(j) * A(j+1:min(j+kd,n),j) +* + JLEN = MIN( KD, N-J ) + IF( JLEN.GT.0 ) + $ CALL DAXPY( JLEN, -X( J )*TSCAL, AB( 2, J ), 1, + $ X( J+1 ), 1 ) + I = J + IDAMAX( N-J, X( J+1 ), 1 ) + XMAX = ABS( X( I ) ) + END IF + 110 CONTINUE +* + ELSE +* +* Solve A**T * 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 = AB( MAIND, 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 + JLEN = MIN( KD, J-1 ) + SUMJ = DDOT( JLEN, AB( KD+1-JLEN, J ), 1, + $ X( J-JLEN ), 1 ) + ELSE + JLEN = MIN( KD, N-J ) + IF( JLEN.GT.0 ) + $ SUMJ = DDOT( JLEN, AB( 2, J ), 1, X( J+1 ), 1 ) + END IF + ELSE +* +* Otherwise, use in-line code for the dot product. +* + IF( UPPER ) THEN + JLEN = MIN( KD, J-1 ) + DO 120 I = 1, JLEN + SUMJ = SUMJ + ( AB( KD+I-JLEN, J )*USCAL )* + $ X( J-JLEN-1+I ) + 120 CONTINUE + ELSE + JLEN = MIN( KD, N-J ) + DO 130 I = 1, JLEN + SUMJ = SUMJ + ( AB( I+1, J )*USCAL )*X( J+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 +* +* Compute x(j) = x(j) / A(j,j), scaling if necessary. +* + TJJS = AB( MAIND, J )*TSCAL + ELSE + TJJS = TSCAL + IF( TSCAL.EQ.ONE ) + $ GO TO 150 + 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/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**T*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 DLATBS +* + END diff --git a/math/lapack/src/main/fortran/dlatdf.f b/math/lapack/src/main/fortran/dlatdf.f new file mode 100644 index 0000000000..fd05059b39 --- /dev/null +++ b/math/lapack/src/main/fortran/dlatdf.f @@ -0,0 +1,323 @@ +*> \brief \b DLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contribution to the reciprocal Dif-estimate. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLATDF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, +* JPIV ) +* +* .. Scalar Arguments .. +* INTEGER IJOB, LDZ, N +* DOUBLE PRECISION RDSCAL, RDSUM +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), JPIV( * ) +* DOUBLE PRECISION RHS( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] IJOB +*> \verbatim +*> IJOB is 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 chosen as either +1 or -1 (Default). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Z. +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is 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 +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDA >= max(1, N). +*> \endverbatim +*> +*> \param[in,out] RHS +*> \verbatim +*> RHS is 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). +*> \endverbatim +*> +*> \param[in,out] RDSUM +*> \verbatim +*> RDSUM is 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. +*> \endverbatim +*> +*> \param[in,out] RDSCAL +*> \verbatim +*> RDSCAL is 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. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N). +*> The pivot indices; for 1 <= i <= N, row i of the +*> matrix has been interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[in] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N). +*> The pivot indices; for 1 <= j <= N, column j of the +*> matrix has been interchanged with column JPIV(j). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> This routine is a further developed implementation of algorithm +*> BSOLVE in [1] using complete pivoting in the LU factorization. +* +*> \par Contributors: +* ================== +*> +*> Bo Kagstrom and Peter Poromaa, Department of Computing Science, +*> Umea University, S-901 87 Umea, Sweden. +* +*> \par References: +* ================ +*> +*> \verbatim +*> +*> +*> [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. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, + $ JPIV ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER IJOB, LDZ, N + DOUBLE PRECISION RDSCAL, RDSUM +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), JPIV( * ) + DOUBLE PRECISION RHS( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlatps.f b/math/lapack/src/main/fortran/dlatps.f new file mode 100644 index 0000000000..c340578f74 --- /dev/null +++ b/math/lapack/src/main/fortran/dlatps.f @@ -0,0 +1,795 @@ +*> \brief \b DLATPS solves a triangular system of equations with the matrix held in packed storage. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLATPS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, +* CNORM, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, NORMIN, TRANS, UPLO +* INTEGER INFO, N +* DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ), CNORM( * ), X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLATPS solves one of the triangular systems +*> +*> A *x = s*b or A**T*x = s*b +*> +*> with scaling to prevent overflow, where A is an upper or lower +*> triangular matrix stored in packed form. Here A**T denotes the +*> transpose of A, x and b are n-element vectors, and s is a scaling +*> factor, usually less than or equal to 1, chosen so that the +*> components of x will be less than the overflow threshold. If the +*> unscaled problem will not cause overflow, the Level 2 BLAS routine +*> DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j), +*> then s is set to 0 and a non-trivial solution to A*x = 0 is returned. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the matrix A is upper or lower triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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**T* x = s*b (Conjugate transpose = Transpose) +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the matrix A is unit triangular. +*> = 'N': Non-unit triangular +*> = 'U': Unit triangular +*> \endverbatim +*> +*> \param[in] NORMIN +*> \verbatim +*> NORMIN is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> The upper or lower triangular matrix A, packed columnwise in +*> a linear array. The j-th column of A is stored in the array +*> AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is 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. +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION +*> The scaling factor s for the triangular system +*> A * x = s*b or A**T* 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. +*> \endverbatim +*> +*> \param[in,out] CNORM +*> \verbatim +*> CNORM is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> A rough bound on x is computed; if that is less than overflow, DTPSV +*> is called, otherwise, specific code is used which checks for possible +*> overflow or divide-by-zero at every operation. +*> +*> A columnwise scheme is used for solving A*x = b. The basic algorithm +*> if A is lower triangular is +*> +*> x[1:n] := b[1:n] +*> for j = 1, ..., n +*> x(j) := x(j) / A(j,j) +*> x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] +*> end +*> +*> Define bounds on the components of x after j iterations of the loop: +*> M(j) = bound on x[1:j] +*> G(j) = bound on x[j+1:n] +*> Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. +*> +*> Then for iteration j+1 we have +*> M(j+1) <= G(j) / | A(j+1,j+1) | +*> G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | +*> <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) +*> +*> where CNORM(j+1) is greater than or equal to the infinity-norm of +*> column j+1 of A, not counting the diagonal. Hence +*> +*> G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) +*> 1<=i<=j +*> and +*> +*> |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) +*> 1<=i< j +*> +*> Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTPSV if the +*> reciprocal of the largest M(j), j=1,..,n, is larger than +*> max(underflow, 1/overflow). +*> +*> The bound on x(j) is also used to determine when a step in the +*> columnwise method can be performed without fear of overflow. If +*> the computed bound is greater than a large constant, x is scaled to +*> prevent overflow, but if the bound overflows, x is set to 0, x(j) to +*> 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. +*> +*> Similarly, a row-wise scheme is used to solve A**T*x = b. The basic +*> algorithm for A upper triangular is +*> +*> for j = 1, ..., n +*> x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j) +*> end +*> +*> We simultaneously compute two bounds +*> G(j) = bound on ( b(i) - A[1:i-1,i]**T * x[1:i-1] ), 1<=i<=j +*> M(j) = bound on x(i), 1<=i<=j +*> +*> The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we +*> add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. +*> Then the bound on x(j) is +*> +*> M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | +*> +*> <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) +*> 1<=i<=j +*> +*> and we can safely call DTPSV if 1/M(n) and 1/G(n) are both greater +*> than max(underflow, 1/overflow). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, + $ CNORM, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, NORMIN, TRANS, UPLO + INTEGER INFO, N + DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), CNORM( * ), X( * ) +* .. +* +* ===================================================================== +* +* .. 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, IP, J, JFIRST, JINC, JLAST, JLEN + 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, DTPSV, 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 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLATPS', -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. +* + IP = 1 + DO 10 J = 1, N + CNORM( J ) = DASUM( J-1, AP( IP ), 1 ) + IP = IP + J + 10 CONTINUE + ELSE +* +* A is lower triangular. +* + IP = 1 + DO 20 J = 1, N - 1 + CNORM( J ) = DASUM( N-J, AP( IP+1 ), 1 ) + IP = IP + N - 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 DTPSV 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 + IP = JFIRST*( JFIRST+1 ) / 2 + JLEN = N + 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( AP( IP ) ) + 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 + IP = IP + JINC*JLEN + JLEN = JLEN - 1 + 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**T * 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 + IP = JFIRST*( JFIRST+1 ) / 2 + JLEN = 1 + 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( AP( IP ) ) + IF( XJ.GT.TJJ ) + $ XBND = XBND*( TJJ / XJ ) + JLEN = JLEN + 1 + IP = IP + JINC*JLEN + 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 DTPSV( UPLO, TRANS, DIAG, N, AP, 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 +* + IP = JFIRST*( JFIRST+1 ) / 2 + 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 = AP( IP )*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, AP( IP-J+1 ), 1, X, + $ 1 ) + I = IDAMAX( J-1, X, 1 ) + XMAX = ABS( X( I ) ) + END IF + IP = IP - J + 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, AP( IP+1 ), 1, + $ X( J+1 ), 1 ) + I = J + IDAMAX( N-J, X( J+1 ), 1 ) + XMAX = ABS( X( I ) ) + END IF + IP = IP + N - J + 1 + END IF + 110 CONTINUE +* + ELSE +* +* Solve A**T * x = b +* + IP = JFIRST*( JFIRST+1 ) / 2 + JLEN = 1 + 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 = AP( IP )*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, AP( IP-J+1 ), 1, X, 1 ) + ELSE IF( J.LT.N ) THEN + SUMJ = DDOT( N-J, AP( IP+1 ), 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 + ( AP( IP-J+I )*USCAL )*X( I ) + 120 CONTINUE + ELSE IF( J.LT.N ) THEN + DO 130 I = 1, N - J + SUMJ = SUMJ + ( AP( IP+I )*USCAL )*X( J+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 +* +* Compute x(j) = x(j) / A(j,j), scaling if necessary. +* + TJJS = AP( IP )*TSCAL + ELSE + TJJS = TSCAL + IF( TSCAL.EQ.ONE ) + $ GO TO 150 + 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/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**T*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 ) ) ) + JLEN = JLEN + 1 + IP = IP + JINC*JLEN + 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 DLATPS +* + END diff --git a/math/lapack/src/main/fortran/dlatrd.f b/math/lapack/src/main/fortran/dlatrd.f new file mode 100644 index 0000000000..a1df43e48a --- /dev/null +++ b/math/lapack/src/main/fortran/dlatrd.f @@ -0,0 +1,336 @@ +*> \brief \b DLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an orthogonal similarity transformation. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLATRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLATRD reduces NB rows and columns of a real symmetric matrix A to +*> symmetric tridiagonal form by an orthogonal similarity +*> transformation Q**T * 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The number of rows and columns to be reduced. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit: +*> if 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= (1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is 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. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is 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. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (LDW,NB) +*> The n-by-nb matrix W required to update the unreduced part +*> of A. +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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**T +*> +*> 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**T +*> +*> 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**T - W*V**T. +*> +*> 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). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDW, N, NB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlatrs.f b/math/lapack/src/main/fortran/dlatrs.f new file mode 100644 index 0000000000..5ad5f66c55 --- /dev/null +++ b/math/lapack/src/main/fortran/dlatrs.f @@ -0,0 +1,787 @@ +*> \brief \b DLATRS solves a triangular system of equations with the scale factor set to prevent overflow. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLATRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, +* CNORM, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, NORMIN, TRANS, UPLO +* INTEGER INFO, LDA, N +* DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLATRS solves one of the triangular systems +*> +*> A *x = s*b or A**T *x = s*b +*> +*> with scaling to prevent overflow. Here A is an upper or lower +*> triangular matrix, A**T 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the matrix A is upper or lower triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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**T* x = s*b (Conjugate transpose = Transpose) +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the matrix A is unit triangular. +*> = 'N': Non-unit triangular +*> = 'U': Unit triangular +*> \endverbatim +*> +*> \param[in] NORMIN +*> \verbatim +*> NORMIN is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max (1,N). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is 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. +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION +*> The scaling factor s for the triangular system +*> A * x = s*b or A**T* 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. +*> \endverbatim +*> +*> \param[in,out] CNORM +*> \verbatim +*> CNORM is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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**T*x = b. The basic +*> algorithm for A upper triangular is +*> +*> for j = 1, ..., n +*> x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j) +*> end +*> +*> We simultaneously compute two bounds +*> G(j) = bound on ( b(i) - A[1:i-1,i]**T * 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). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, + $ CNORM, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, NORMIN, TRANS, UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * ) +* .. +* +* ===================================================================== +* +* .. 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**T * 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**T * 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**T*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/math/lapack/src/main/fortran/dlatrz.f b/math/lapack/src/main/fortran/dlatrz.f new file mode 100644 index 0000000000..8fbe87585c --- /dev/null +++ b/math/lapack/src/main/fortran/dlatrz.f @@ -0,0 +1,200 @@ +*> \brief \b DLATRZ factors an upper trapezoidal matrix by means of orthogonal transformations. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLATRZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK ) +* +* .. Scalar Arguments .. +* INTEGER L, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of columns of the matrix A containing the +*> meaningful part of the Householder vectors. N-M >= L >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (M) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (M) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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 )**T, 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 ). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER L, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dlatsqr.f b/math/lapack/src/main/fortran/dlatsqr.f new file mode 100644 index 0000000000..1ce7c4de07 --- /dev/null +++ b/math/lapack/src/main/fortran/dlatsqr.f @@ -0,0 +1,256 @@ +* +* Definition: +* =========== +* +* SUBROUTINE DLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, +* LWORK, INFO) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLATSQR computes a blocked Tall-Skinny QR factorization of +*> an M-by-N matrix A, where M >= N: +*> A = Q * R . +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The row block size to be used in the blocked QR. +*> MB > N. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> N >= NB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and above the diagonal +*> of the array contain the N-by-N upper triangular matrix R; +*> the elements below the diagonal represent Q by the columns +*> of blocked V (see Further Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, +*> dimension (LDT, N * Number_of_row_blocks) +*> where Number_of_row_blocks = CEIL((M-N)/(MB-N)) +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. +*> See Further Details below. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> The dimension of the array WORK. LWORK >= NB*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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A: +*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A +*> . . . +*> +*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GEQRT. +*> +*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors +*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, + $ LWORK, INFO) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. -- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ), T(LDT, *) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, II, KK, CTR +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DGEQRT, DTPQRT, XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN, MOD +* .. +* .. 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. M.LT.N ) THEN + INFO = -2 + ELSE IF( MB.LE.N ) THEN + INFO = -3 + ELSE IF( NB.LT.1 .OR. ( NB.GT.N .AND. N.GT.0 )) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDT.LT.NB ) THEN + INFO = -8 + ELSE IF( LWORK.LT.(N*NB) .AND. (.NOT.LQUERY) ) THEN + INFO = -10 + END IF + IF( INFO.EQ.0) THEN + WORK(1) = NB*N + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLATSQR', -INFO ) + RETURN + ELSE IF (LQUERY) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N).EQ.0 ) THEN + RETURN + END IF +* +* The QR Decomposition +* + IF ((MB.LE.N).OR.(MB.GE.M)) THEN + CALL DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO) + RETURN + END IF +* + KK = MOD((M-N),(MB-N)) + II=M-KK+1 +* +* Compute the QR factorization of the first block A(1:MB,1:N) +* + CALL DGEQRT( MB, N, NB, A(1,1), LDA, T, LDT, WORK, INFO ) +* + CTR = 1 + DO I = MB+1, II-MB+N , (MB-N) +* +* Compute the QR factorization of the current block A(I:I+MB-N,1:N) +* + CALL DTPQRT( MB-N, N, 0, NB, A(1,1), LDA, A( I, 1 ), LDA, + $ T(1, CTR * N + 1), + $ LDT, WORK, INFO ) + CTR = CTR + 1 + END DO +* +* Compute the QR factorization of the last block A(II:M,1:N) +* + IF (II.LE.M) THEN + CALL DTPQRT( KK, N, 0, NB, A(1,1), LDA, A( II, 1 ), LDA, + $ T(1, CTR * N + 1), LDT, + $ WORK, INFO ) + END IF +* + WORK( 1 ) = N*NB + RETURN +* +* End of DLATSQR +* + END diff --git a/math/lapack/src/main/fortran/dlauu2.f b/math/lapack/src/main/fortran/dlauu2.f new file mode 100644 index 0000000000..59cff25614 --- /dev/null +++ b/math/lapack/src/main/fortran/dlauu2.f @@ -0,0 +1,198 @@ +*> \brief \b DLAUU2 computes the product UUH or LHL, where U and L are upper or lower triangular matrices (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAUU2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAUU2 computes the product U * U**T or L**T * L, where the triangular +*> factor U or L is stored in the upper or lower triangular part of +*> the array A. +*> +*> If UPLO = 'U' or 'u' then the upper triangle of the result is stored, +*> overwriting the factor U in A. +*> If UPLO = 'L' or 'l' then the lower triangle of the result is stored, +*> overwriting the factor L in A. +*> +*> This is the unblocked form of the algorithm, calling Level 2 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the triangular factor stored in the array A +*> is upper or lower triangular: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the triangular factor U or L. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the triangular factor U or L. +*> On exit, if UPLO = 'U', the upper triangle of A is +*> overwritten with the upper triangle of the product U * U**T; +*> if UPLO = 'L', the lower triangle of A is overwritten with +*> the lower triangle of the product L**T * L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I + DOUBLE PRECISION AII +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DSCAL, 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 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAUU2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Compute the product U * U**T. +* + DO 10 I = 1, N + AII = A( I, I ) + IF( I.LT.N ) THEN + A( I, I ) = DDOT( N-I+1, A( I, I ), LDA, A( I, I ), LDA ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), + $ LDA, A( I, I+1 ), LDA, AII, A( 1, I ), 1 ) + ELSE + CALL DSCAL( I, AII, A( 1, I ), 1 ) + END IF + 10 CONTINUE +* + ELSE +* +* Compute the product L**T * L. +* + DO 20 I = 1, N + AII = A( I, I ) + IF( I.LT.N ) THEN + A( I, I ) = DDOT( N-I+1, A( I, I ), 1, A( I, I ), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, + $ A( I+1, I ), 1, AII, A( I, 1 ), LDA ) + ELSE + CALL DSCAL( I, AII, A( I, 1 ), LDA ) + END IF + 20 CONTINUE + END IF +* + RETURN +* +* End of DLAUU2 +* + END diff --git a/math/lapack/src/main/fortran/dlauum.f b/math/lapack/src/main/fortran/dlauum.f new file mode 100644 index 0000000000..31b1ddd06f --- /dev/null +++ b/math/lapack/src/main/fortran/dlauum.f @@ -0,0 +1,218 @@ +*> \brief \b DLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAUUM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAUUM computes the product U * U**T or L**T * L, where the triangular +*> factor U or L is stored in the upper or lower triangular part of +*> the array A. +*> +*> If UPLO = 'U' or 'u' then the upper triangle of the result is stored, +*> overwriting the factor U in A. +*> If UPLO = 'L' or 'l' then the lower triangle of the result is stored, +*> overwriting the factor L in A. +*> +*> This is the blocked form of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the triangular factor stored in the array A +*> is upper or lower triangular: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the triangular factor U or L. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the triangular factor U or L. +*> On exit, if UPLO = 'U', the upper triangle of A is +*> overwritten with the upper triangle of the product U * U**T; +*> if UPLO = 'L', the lower triangle of A is overwritten with +*> the lower triangle of the product L**T * L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IB, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLAUU2, DSYRK, DTRMM, 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( 'DLAUUM', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'DLAUUM', UPLO, N, -1, -1, -1 ) +* + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL DLAUU2( UPLO, N, A, LDA, INFO ) + ELSE +* +* Use blocked code +* + IF( UPPER ) THEN +* +* Compute the product U * U**T. +* + DO 10 I = 1, N, NB + IB = MIN( NB, N-I+1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', + $ I-1, IB, ONE, A( I, I ), LDA, A( 1, I ), + $ LDA ) + CALL DLAUU2( 'Upper', IB, A( I, I ), LDA, INFO ) + IF( I+IB.LE.N ) THEN + CALL DGEMM( 'No transpose', 'Transpose', I-1, IB, + $ N-I-IB+1, ONE, A( 1, I+IB ), LDA, + $ A( I, I+IB ), LDA, ONE, A( 1, I ), LDA ) + CALL DSYRK( 'Upper', 'No transpose', IB, N-I-IB+1, + $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ), + $ LDA ) + END IF + 10 CONTINUE + ELSE +* +* Compute the product L**T * L. +* + DO 20 I = 1, N, NB + IB = MIN( NB, N-I+1 ) + CALL DTRMM( 'Left', 'Lower', 'Transpose', 'Non-unit', IB, + $ I-1, ONE, A( I, I ), LDA, A( I, 1 ), LDA ) + CALL DLAUU2( 'Lower', IB, A( I, I ), LDA, INFO ) + IF( I+IB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No transpose', IB, I-1, + $ N-I-IB+1, ONE, A( I+IB, I ), LDA, + $ A( I+IB, 1 ), LDA, ONE, A( I, 1 ), LDA ) + CALL DSYRK( 'Lower', 'Transpose', IB, N-I-IB+1, ONE, + $ A( I+IB, I ), LDA, ONE, A( I, I ), LDA ) + END IF + 20 CONTINUE + END IF + END IF +* + RETURN +* +* End of DLAUUM +* + END diff --git a/math/lapack/src/main/fortran/dopgtr.f b/math/lapack/src/main/fortran/dopgtr.f new file mode 100644 index 0000000000..0e061b219f --- /dev/null +++ b/math/lapack/src/main/fortran/dopgtr.f @@ -0,0 +1,232 @@ +*> \brief \b DOPGTR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DOPGTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDQ, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangular packed storage used in previous +*> call to DSPTRD; +*> = 'L': Lower triangular packed storage used in previous +*> call to DSPTRD. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix Q. N >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> The vectors which define the elementary reflectors, as +*> returned by DSPTRD. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-1) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DSPTRD. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ,N) +*> The N-by-N orthogonal matrix Q. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N-1) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDQ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dopmtr.f b/math/lapack/src/main/fortran/dopmtr.f new file mode 100644 index 0000000000..dd9286b351 --- /dev/null +++ b/math/lapack/src/main/fortran/dopmtr.f @@ -0,0 +1,339 @@ +*> \brief \b DOPMTR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DOPMTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS, UPLO +* INTEGER INFO, LDC, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DOPMTR overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> +*> where Q is a real orthogonal matrix of order nq, with nq = m if +*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of +*> nq-1 elementary reflectors, as returned by DSPTRD using packed +*> storage: +*> +*> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); +*> +*> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangular packed storage used in previous +*> call to DSPTRD; +*> = 'L': Lower triangular packed storage used in previous +*> call to DSPTRD. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension +*> (M*(M+1)/2) if SIDE = 'L' +*> (N*(N+1)/2) if SIDE = 'R' +*> The vectors which define the elementary reflectors, as +*> returned by DSPTRD. AP is modified by the routine but +*> restored on exit. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L' +*> or (N-1) if SIDE = 'R' +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DSPTRD. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L' +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS, UPLO + INTEGER INFO, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL FORWRD, LEFT, NOTRAN, UPPER + INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ + DOUBLE PRECISION AII +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + UPPER = LSAME( UPLO, 'U' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DOPMTR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Q was determined by a call to DSPTRD with UPLO = 'U' +* + FORWRD = ( LEFT .AND. NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) +* + IF( FORWRD ) THEN + I1 = 1 + I2 = NQ - 1 + I3 = 1 + II = 2 + ELSE + I1 = NQ - 1 + I2 = 1 + I3 = -1 + II = NQ*( NQ+1 ) / 2 - 1 + END IF +* + IF( LEFT ) THEN + NI = N + ELSE + MI = M + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) is applied to C(1:i,1:n) +* + MI = I + ELSE +* +* H(i) is applied to C(1:m,1:i) +* + NI = I + END IF +* +* Apply H(i) +* + AII = AP( II ) + AP( II ) = ONE + CALL DLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC, + $ WORK ) + AP( II ) = AII +* + IF( FORWRD ) THEN + II = II + I + 2 + ELSE + II = II - I - 1 + END IF + 10 CONTINUE + ELSE +* +* Q was determined by a call to DSPTRD with UPLO = 'L'. +* + FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) +* + IF( FORWRD ) THEN + I1 = 1 + I2 = NQ - 1 + I3 = 1 + II = 2 + ELSE + I1 = NQ - 1 + I2 = 1 + I3 = -1 + II = NQ*( NQ+1 ) / 2 - 1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 20 I = I1, I2, I3 + AII = AP( II ) + AP( II ) = ONE + IF( LEFT ) THEN +* +* H(i) is applied to C(i+1:m,1:n) +* + MI = M - I + IC = I + 1 + ELSE +* +* H(i) is applied to C(1:m,i+1:n) +* + NI = N - I + JC = I + 1 + END IF +* +* Apply H(i) +* + CALL DLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ), + $ C( IC, JC ), LDC, WORK ) + AP( II ) = AII +* + IF( FORWRD ) THEN + II = II + NQ - I + 1 + ELSE + II = II - NQ + I - 2 + END IF + 20 CONTINUE + END IF + RETURN +* +* End of DOPMTR +* + END diff --git a/math/lapack/src/main/fortran/dorbdb.f b/math/lapack/src/main/fortran/dorbdb.f new file mode 100644 index 0000000000..d616579945 --- /dev/null +++ b/math/lapack/src/main/fortran/dorbdb.f @@ -0,0 +1,687 @@ +*> \brief \b DORBDB +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORBDB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, +* X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, +* TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIGNS, TRANS +* INTEGER INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P, +* $ Q +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI( * ), THETA( * ) +* DOUBLE PRECISION TAUP1( * ), TAUP2( * ), TAUQ1( * ), TAUQ2( * ), +* $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ), +* $ X21( LDX21, * ), X22( LDX22, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORBDB simultaneously bidiagonalizes the blocks of an M-by-M +*> partitioned orthogonal matrix X: +*> +*> [ B11 | B12 0 0 ] +*> [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**T +*> X = [-----------] = [---------] [----------------] [---------] . +*> [ X21 | X22 ] [ | P2 ] [ B21 | B22 0 0 ] [ | Q2 ] +*> [ 0 | 0 0 I ] +*> +*> X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is +*> not the case, then X must be transposed and/or permuted. This can be +*> done in constant time using the TRANS and SIGNS options. See DORCSD +*> for details.) +*> +*> The orthogonal matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by- +*> (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are +*> represented implicitly by Householder vectors. +*> +*> B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER +*> = 'T': X, U1, U2, V1T, and V2T are stored in row-major +*> order; +*> otherwise: X, U1, U2, V1T, and V2T are stored in column- +*> major order. +*> \endverbatim +*> +*> \param[in] SIGNS +*> \verbatim +*> SIGNS is CHARACTER +*> = 'O': The lower-left block is made nonpositive (the +*> "other" convention); +*> otherwise: The upper-right block is made nonpositive (the +*> "default" convention). +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows and columns in X. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11 and X12. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= +*> MIN(P,M-P,M-Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, the top-left block of the orthogonal matrix to be +*> reduced. On exit, the form depends on TRANS: +*> If TRANS = 'N', then +*> the columns of tril(X11) specify reflectors for P1, +*> the rows of triu(X11,1) specify reflectors for Q1; +*> else TRANS = 'T', and +*> the rows of triu(X11) specify reflectors for P1, +*> the columns of tril(X11,-1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. If TRANS = 'N', then LDX11 >= +*> P; else LDX11 >= Q. +*> \endverbatim +*> +*> \param[in,out] X12 +*> \verbatim +*> X12 is DOUBLE PRECISION array, dimension (LDX12,M-Q) +*> On entry, the top-right block of the orthogonal matrix to +*> be reduced. On exit, the form depends on TRANS: +*> If TRANS = 'N', then +*> the rows of triu(X12) specify the first P reflectors for +*> Q2; +*> else TRANS = 'T', and +*> the columns of tril(X12) specify the first P reflectors +*> for Q2. +*> \endverbatim +*> +*> \param[in] LDX12 +*> \verbatim +*> LDX12 is INTEGER +*> The leading dimension of X12. If TRANS = 'N', then LDX12 >= +*> P; else LDX11 >= M-Q. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, the bottom-left block of the orthogonal matrix to +*> be reduced. On exit, the form depends on TRANS: +*> If TRANS = 'N', then +*> the columns of tril(X21) specify reflectors for P2; +*> else TRANS = 'T', and +*> the rows of triu(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. If TRANS = 'N', then LDX21 >= +*> M-P; else LDX21 >= Q. +*> \endverbatim +*> +*> \param[in,out] X22 +*> \verbatim +*> X22 is DOUBLE PRECISION array, dimension (LDX22,M-Q) +*> On entry, the bottom-right block of the orthogonal matrix to +*> be reduced. On exit, the form depends on TRANS: +*> If TRANS = 'N', then +*> the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last +*> M-P-Q reflectors for Q2, +*> else TRANS = 'T', and +*> the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last +*> M-P-Q reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX22 +*> \verbatim +*> LDX22 is INTEGER +*> The leading dimension of X22. If TRANS = 'N', then LDX22 >= +*> M-P; else LDX22 >= M-Q. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B12, B21, B22 can +*> be computed from the angles THETA and PHI. See Further +*> Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B12, B21, B22 can +*> be computed from the angles THETA and PHI. See Further +*> Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is DOUBLE PRECISION array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is DOUBLE PRECISION array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is DOUBLE PRECISION array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] TAUQ2 +*> \verbatim +*> TAUQ2 is DOUBLE PRECISION array, dimension (M-Q) +*> The scalar factors of the elementary reflectors that define +*> Q2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The bidiagonal blocks B11, B12, B21, and B22 are represented +*> implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ..., +*> PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are +*> lower bidiagonal. Every entry in each bidiagonal band is a product +*> of a sine or cosine of a THETA with a sine or cosine of a PHI. See +*> [1] or DORCSD for details. +*> +*> P1, P2, Q1, and Q2 are represented as products of elementary +*> reflectors. See DORCSD for details on generating P1, P2, Q1, and Q2 +*> using DORGQR and DORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, + $ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, + $ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIGNS, TRANS + INTEGER INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P, + $ Q +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI( * ), THETA( * ) + DOUBLE PRECISION TAUP1( * ), TAUP2( * ), TAUQ1( * ), TAUQ2( * ), + $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ), + $ X21( LDX21, * ), X22( LDX22, * ) +* .. +* +* ==================================================================== +* +* .. Parameters .. + DOUBLE PRECISION REALONE + PARAMETER ( REALONE = 1.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL COLMAJOR, LQUERY + INTEGER I, LWORKMIN, LWORKOPT + DOUBLE PRECISION Z1, Z2, Z3, Z4 +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DLARF, DLARFGP, DSCAL, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DNRM2 + LOGICAL LSAME + EXTERNAL DNRM2, LSAME +* .. +* .. Intrinsic Functions + INTRINSIC ATAN2, COS, MAX, SIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + COLMAJOR = .NOT. LSAME( TRANS, 'T' ) + IF( .NOT. LSAME( SIGNS, 'O' ) ) THEN + Z1 = REALONE + Z2 = REALONE + Z3 = REALONE + Z4 = REALONE + ELSE + Z1 = REALONE + Z2 = -REALONE + Z3 = REALONE + Z4 = -REALONE + END IF + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -3 + ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN + INFO = -4 + ELSE IF( Q .LT. 0 .OR. Q .GT. P .OR. Q .GT. M-P .OR. + $ Q .GT. M-Q ) THEN + INFO = -5 + ELSE IF( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -7 + ELSE IF( .NOT.COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN + INFO = -7 + ELSE IF( COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN + INFO = -9 + ELSE IF( .NOT.COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN + INFO = -9 + ELSE IF( COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -11 + ELSE IF( .NOT.COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN + INFO = -11 + ELSE IF( COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN + INFO = -13 + ELSE IF( .NOT.COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN + INFO = -13 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + LWORKOPT = M - Q + LWORKMIN = M - Q + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT. LQUERY ) THEN + INFO = -21 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'xORBDB', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Handle column-major and row-major separately +* + IF( COLMAJOR ) THEN +* +* Reduce columns 1, ..., Q of X11, X12, X21, and X22 +* + DO I = 1, Q +* + IF( I .EQ. 1 ) THEN + CALL DSCAL( P-I+1, Z1, X11(I,I), 1 ) + ELSE + CALL DSCAL( P-I+1, Z1*COS(PHI(I-1)), X11(I,I), 1 ) + CALL DAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I,I-1), + $ 1, X11(I,I), 1 ) + END IF + IF( I .EQ. 1 ) THEN + CALL DSCAL( M-P-I+1, Z2, X21(I,I), 1 ) + ELSE + CALL DSCAL( M-P-I+1, Z2*COS(PHI(I-1)), X21(I,I), 1 ) + CALL DAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I,I-1), + $ 1, X21(I,I), 1 ) + END IF +* + THETA(I) = ATAN2( DNRM2( M-P-I+1, X21(I,I), 1 ), + $ DNRM2( P-I+1, X11(I,I), 1 ) ) +* + IF( P .GT. I ) THEN + CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + ELSE IF( P .EQ. I ) THEN + CALL DLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) ) + END IF + X11(I,I) = ONE + IF ( M-P .GT. I ) THEN + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, + $ TAUP2(I) ) + ELSE IF ( M-P .EQ. I ) THEN + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, TAUP2(I) ) + END IF + X21(I,I) = ONE +* + IF ( Q .GT. I ) THEN + CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), + $ X11(I,I+1), LDX11, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL DLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, TAUP1(I), + $ X12(I,I), LDX12, WORK ) + END IF + IF ( Q .GT. I ) THEN + CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL DLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, TAUP2(I), + $ X22(I,I), LDX22, WORK ) + END IF +* + IF( I .LT. Q ) THEN + CALL DSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I,I+1), + $ LDX11 ) + CALL DAXPY( Q-I, Z2*Z3*COS(THETA(I)), X21(I,I+1), LDX21, + $ X11(I,I+1), LDX11 ) + END IF + CALL DSCAL( M-Q-I+1, -Z1*Z4*SIN(THETA(I)), X12(I,I), LDX12 ) + CALL DAXPY( M-Q-I+1, Z2*Z4*COS(THETA(I)), X22(I,I), LDX22, + $ X12(I,I), LDX12 ) +* + IF( I .LT. Q ) + $ PHI(I) = ATAN2( DNRM2( Q-I, X11(I,I+1), LDX11 ), + $ DNRM2( M-Q-I+1, X12(I,I), LDX12 ) ) +* + IF( I .LT. Q ) THEN + IF ( Q-I .EQ. 1 ) THEN + CALL DLARFGP( Q-I, X11(I,I+1), X11(I,I+1), LDX11, + $ TAUQ1(I) ) + ELSE + CALL DLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11, + $ TAUQ1(I) ) + END IF + X11(I,I+1) = ONE + END IF + IF ( Q+I-1 .LT. M ) THEN + IF ( M-Q .EQ. I ) THEN + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12, + $ TAUQ2(I) ) + ELSE + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, + $ TAUQ2(I) ) + END IF + END IF + X12(I,I) = ONE +* + IF( I .LT. Q ) THEN + CALL DLARF( 'R', P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK ) + CALL DLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I), + $ X21(I+1,I+1), LDX21, WORK ) + END IF + IF ( P .GT. I ) THEN + CALL DLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) + END IF + IF ( M-P .GT. I ) THEN + CALL DLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(I+1,I), LDX22, WORK ) + END IF +* + END DO +* +* Reduce columns Q + 1, ..., P of X12, X22 +* + DO I = Q + 1, P +* + CALL DSCAL( M-Q-I+1, -Z1*Z4, X12(I,I), LDX12 ) + IF ( I .GE. M-Q ) THEN + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12, + $ TAUQ2(I) ) + ELSE + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, + $ TAUQ2(I) ) + END IF + X12(I,I) = ONE +* + IF ( P .GT. I ) THEN + CALL DLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) + END IF + IF( M-P-Q .GE. 1 ) + $ CALL DLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(Q+1,I), LDX22, WORK ) +* + END DO +* +* Reduce columns P + 1, ..., M - Q of X12, X22 +* + DO I = 1, M - P - Q +* + CALL DSCAL( M-P-Q-I+1, Z2*Z4, X22(Q+I,P+I), LDX22 ) + IF ( I .EQ. M-P-Q ) THEN + CALL DLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I), + $ LDX22, TAUQ2(P+I) ) + ELSE + CALL DLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1), + $ LDX22, TAUQ2(P+I) ) + END IF + X22(Q+I,P+I) = ONE + IF ( I .LT. M-P-Q ) THEN + CALL DLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22, + $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK ) + END IF +* + END DO +* + ELSE +* +* Reduce columns 1, ..., Q of X11, X12, X21, X22 +* + DO I = 1, Q +* + IF( I .EQ. 1 ) THEN + CALL DSCAL( P-I+1, Z1, X11(I,I), LDX11 ) + ELSE + CALL DSCAL( P-I+1, Z1*COS(PHI(I-1)), X11(I,I), LDX11 ) + CALL DAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I-1,I), + $ LDX12, X11(I,I), LDX11 ) + END IF + IF( I .EQ. 1 ) THEN + CALL DSCAL( M-P-I+1, Z2, X21(I,I), LDX21 ) + ELSE + CALL DSCAL( M-P-I+1, Z2*COS(PHI(I-1)), X21(I,I), LDX21 ) + CALL DAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I-1,I), + $ LDX22, X21(I,I), LDX21 ) + END IF +* + THETA(I) = ATAN2( DNRM2( M-P-I+1, X21(I,I), LDX21 ), + $ DNRM2( P-I+1, X11(I,I), LDX11 ) ) +* + CALL DLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) ) + X11(I,I) = ONE + IF ( I .EQ. M-P ) THEN + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21, + $ TAUP2(I) ) + ELSE + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21, + $ TAUP2(I) ) + END IF + X21(I,I) = ONE +* + IF ( Q .GT. I ) THEN + CALL DLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I), + $ X11(I+1,I), LDX11, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL DLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, + $ TAUP1(I), X12(I,I), LDX12, WORK ) + END IF + IF ( Q .GT. I ) THEN + CALL DLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I), + $ X21(I+1,I), LDX21, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL DLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, + $ TAUP2(I), X22(I,I), LDX22, WORK ) + END IF +* + IF( I .LT. Q ) THEN + CALL DSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I+1,I), 1 ) + CALL DAXPY( Q-I, Z2*Z3*COS(THETA(I)), X21(I+1,I), 1, + $ X11(I+1,I), 1 ) + END IF + CALL DSCAL( M-Q-I+1, -Z1*Z4*SIN(THETA(I)), X12(I,I), 1 ) + CALL DAXPY( M-Q-I+1, Z2*Z4*COS(THETA(I)), X22(I,I), 1, + $ X12(I,I), 1 ) +* + IF( I .LT. Q ) + $ PHI(I) = ATAN2( DNRM2( Q-I, X11(I+1,I), 1 ), + $ DNRM2( M-Q-I+1, X12(I,I), 1 ) ) +* + IF( I .LT. Q ) THEN + IF ( Q-I .EQ. 1) THEN + CALL DLARFGP( Q-I, X11(I+1,I), X11(I+1,I), 1, + $ TAUQ1(I) ) + ELSE + CALL DLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, + $ TAUQ1(I) ) + END IF + X11(I+1,I) = ONE + END IF + IF ( M-Q .GT. I ) THEN + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, + $ TAUQ2(I) ) + ELSE + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), 1, + $ TAUQ2(I) ) + END IF + X12(I,I) = ONE +* + IF( I .LT. Q ) THEN + CALL DLARF( 'L', Q-I, P-I, X11(I+1,I), 1, TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK ) + CALL DLARF( 'L', Q-I, M-P-I, X11(I+1,I), 1, TAUQ1(I), + $ X21(I+1,I+1), LDX21, WORK ) + END IF + CALL DLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), + $ X12(I,I+1), LDX12, WORK ) + IF ( M-P-I .GT. 0 ) THEN + CALL DLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, TAUQ2(I), + $ X22(I,I+1), LDX22, WORK ) + END IF +* + END DO +* +* Reduce columns Q + 1, ..., P of X12, X22 +* + DO I = Q + 1, P +* + CALL DSCAL( M-Q-I+1, -Z1*Z4, X12(I,I), 1 ) + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) ) + X12(I,I) = ONE +* + IF ( P .GT. I ) THEN + CALL DLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), + $ X12(I,I+1), LDX12, WORK ) + END IF + IF( M-P-Q .GE. 1 ) + $ CALL DLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, TAUQ2(I), + $ X22(I,Q+1), LDX22, WORK ) +* + END DO +* +* Reduce columns P + 1, ..., M - Q of X12, X22 +* + DO I = 1, M - P - Q +* + CALL DSCAL( M-P-Q-I+1, Z2*Z4, X22(P+I,Q+I), 1 ) + IF ( M-P-Q .EQ. I ) THEN + CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I,Q+I), 1, + $ TAUQ2(P+I) ) + ELSE + CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1, + $ TAUQ2(P+I) ) + CALL DLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1, + $ TAUQ2(P+I), X22(P+I,Q+I+1), LDX22, WORK ) + END IF + X22(P+I,Q+I) = ONE +* + END DO +* + END IF +* + RETURN +* +* End of DORBDB +* + END + diff --git a/math/lapack/src/main/fortran/dorbdb1.f b/math/lapack/src/main/fortran/dorbdb1.f new file mode 100644 index 0000000000..db3b14db22 --- /dev/null +++ b/math/lapack/src/main/fortran/dorbdb1.f @@ -0,0 +1,323 @@ +*> \brief \b DORBDB1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORBDB1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> DORBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P, +*> M-P, or M-Q. Routines DORBDB2, DORBDB3, and DORBDB4 handle cases in +*> which Q is not the minimum dimension. +*> +*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by +*> angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= +*> MIN(P,M-P,M-Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is DOUBLE PRECISION array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is DOUBLE PRECISION array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is DOUBLE PRECISION array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +*> +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or DORCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR +*> and DORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN + INFO = -2 + ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P-1, M-P-1, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-2 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORBDB1', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce columns 1, ..., Q of X11 and X21 +* + DO I = 1, Q +* + CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + THETA(I) = ATAN2( X21(I,I), X11(I,I) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + X11(I,I) = ONE + X21(I,I) = ONE + CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1), + $ LDX11, WORK(ILARF) ) + CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) +* + IF( I .LT. Q ) THEN + CALL DROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, S ) + CALL DLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) ) + S = X21(I,I+1) + X21(I,I+1) = ONE + CALL DLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + CALL DLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), + $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + C = SQRT( DNRM2( P-I, X11(I+1,I+1), 1 )**2 + $ + DNRM2( M-P-I, X21(I+1,I+1), 1 )**2 ) + PHI(I) = ATAN2( S, C ) + CALL DORBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1, + $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11, + $ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5, + $ CHILDINFO ) + END IF +* + END DO +* + RETURN +* +* End of DORBDB1 +* + END + diff --git a/math/lapack/src/main/fortran/dorbdb2.f b/math/lapack/src/main/fortran/dorbdb2.f new file mode 100644 index 0000000000..cec60da75a --- /dev/null +++ b/math/lapack/src/main/fortran/dorbdb2.f @@ -0,0 +1,333 @@ +*> \brief \b DORBDB2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORBDB2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> DORBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P, +*> Q, or M-Q. Routines DORBDB1, DORBDB3, and DORBDB4 handle cases in +*> which P is not the minimum dimension. +*> +*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by +*> angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q). +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is DOUBLE PRECISION array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is DOUBLE PRECISION array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is DOUBLE PRECISION array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +*> +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or DORCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR +*> and DORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + DOUBLE PRECISION NEGONE, ONE + PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, DSCAL, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN + INFO = -2 + ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P-1, M-P, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-1 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORBDB2', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce rows 1, ..., P of X11 and X21 +* + DO I = 1, P +* + IF( I .GT. 1 ) THEN + CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, S ) + END IF + CALL DLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) + C = X11(I,I) + X11(I,I) = ONE + CALL DLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL DLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X21(I,I), LDX21, WORK(ILARF) ) + S = SQRT( DNRM2( P-I, X11(I+1,I), 1 )**2 + $ + DNRM2( M-P-I+1, X21(I,I), 1 )**2 ) + THETA(I) = ATAN2( S, C ) +* + CALL DORBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1, + $ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21, + $ WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL DSCAL( P-I, NEGONE, X11(I+1,I), 1 ) + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + IF( I .LT. P ) THEN + CALL DLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) ) + PHI(I) = ATAN2( X11(I+1,I), X21(I,I) ) + C = COS( PHI(I) ) + S = SIN( PHI(I) ) + X11(I+1,I) = ONE + CALL DLARF( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + END IF + X21(I,I) = ONE + CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) +* + END DO +* +* Reduce the bottom-right portion of X21 to the identity matrix +* + DO I = P + 1, Q + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + X21(I,I) = ONE + CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) + END DO +* + RETURN +* +* End of DORBDB2 +* + END + diff --git a/math/lapack/src/main/fortran/dorbdb3.f b/math/lapack/src/main/fortran/dorbdb3.f new file mode 100644 index 0000000000..7149796ca3 --- /dev/null +++ b/math/lapack/src/main/fortran/dorbdb3.f @@ -0,0 +1,332 @@ +*> \brief \b DORBDB3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORBDB3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> DORBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P, +*> Q, or M-Q. Routines DORBDB1, DORBDB2, and DORBDB4 handle cases in +*> which M-P is not the minimum dimension. +*> +*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q). +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is DOUBLE PRECISION array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is DOUBLE PRECISION array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is DOUBLE PRECISION array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or DORCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR +*> and DORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN + INFO = -2 + ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P, M-P-1, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-1 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORBDB3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce rows 1, ..., M-P of X11 and X21 +* + DO I = 1, M-P +* + IF( I .GT. 1 ) THEN + CALL DROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, S ) + END IF +* + CALL DLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) + S = X21(I,I) + X21(I,I) = ONE + CALL DLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL DLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) + C = SQRT( DNRM2( P-I+1, X11(I,I), 1 )**2 + $ + DNRM2( M-P-I, X21(I+1,I), 1 )**2 ) + THETA(I) = ATAN2( S, C ) +* + CALL DORBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1, + $ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21, + $ WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + IF( I .LT. M-P ) THEN + CALL DLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) ) + PHI(I) = ATAN2( X21(I+1,I), X11(I,I) ) + C = COS( PHI(I) ) + S = SIN( PHI(I) ) + X21(I+1,I) = ONE + CALL DLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I), + $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + END IF + X11(I,I) = ONE + CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1), + $ LDX11, WORK(ILARF) ) +* + END DO +* +* Reduce the bottom-right portion of X11 to the identity matrix +* + DO I = M-P + 1, Q + CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + X11(I,I) = ONE + CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1), + $ LDX11, WORK(ILARF) ) + END DO +* + RETURN +* +* End of DORBDB3 +* + END + diff --git a/math/lapack/src/main/fortran/dorbdb4.f b/math/lapack/src/main/fortran/dorbdb4.f new file mode 100644 index 0000000000..606d7083bc --- /dev/null +++ b/math/lapack/src/main/fortran/dorbdb4.f @@ -0,0 +1,377 @@ +*> \brief \b DORBDB4 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORBDB4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* DOUBLE PRECISION PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), +* $ WORK(*), X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> DORBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P, +*> M-P, or Q. Routines DORBDB1, DORBDB2, and DORBDB3 handle cases in +*> which M-Q is not the minimum dimension. +*> +*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M and +*> M-Q <= min(P,M-P,Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is DOUBLE PRECISION array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is DOUBLE PRECISION array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is DOUBLE PRECISION array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] PHANTOM +*> \verbatim +*> PHANTOM is DOUBLE PRECISION array, dimension (M) +*> The routine computes an M-by-1 column vector Y that is +*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and +*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and +*> Y(P+1:M), respectively. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or DORCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR +*> and DORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + DOUBLE PRECISION PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), + $ WORK(*), X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + DOUBLE PRECISION NEGONE, ONE, ZERO + PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF, + $ LORBDB5, LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, DSCAL, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN + INFO = -2 + ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( Q-1, P-1, M-P-1 ) + IORBDB5 = 2 + LORBDB5 = Q + LWORKOPT = ILARF + LLARF - 1 + LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORBDB4', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce columns 1, ..., M-Q of X11 and X21 +* + DO I = 1, M-Q +* + IF( I .EQ. 1 ) THEN + DO J = 1, M + PHANTOM(J) = ZERO + END DO + CALL DORBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1, + $ X11, LDX11, X21, LDX21, WORK(IORBDB5), + $ LORBDB5, CHILDINFO ) + CALL DSCAL( P, NEGONE, PHANTOM(1), 1 ) + CALL DLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) ) + CALL DLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) ) + THETA(I) = ATAN2( PHANTOM(1), PHANTOM(P+1) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + PHANTOM(1) = ONE + PHANTOM(P+1) = ONE + CALL DLARF( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11, LDX11, + $ WORK(ILARF) ) + CALL DLARF( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), X21, + $ LDX21, WORK(ILARF) ) + ELSE + CALL DORBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1, + $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I), + $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL DSCAL( P-I+1, NEGONE, X11(I,I-1), 1 ) + CALL DLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) ) + CALL DLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1, + $ TAUP2(I) ) + THETA(I) = ATAN2( X11(I,I-1), X21(I,I-1) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + X11(I,I-1) = ONE + X21(I,I-1) = ONE + CALL DLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL DLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, TAUP2(I), + $ X21(I,I), LDX21, WORK(ILARF) ) + END IF +* + CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C ) + CALL DLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) + C = X21(I,I) + X21(I,I) = ONE + CALL DLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL DLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) + IF( I .LT. M-Q ) THEN + S = SQRT( DNRM2( P-I, X11(I+1,I), 1 )**2 + $ + DNRM2( M-P-I, X21(I+1,I), 1 )**2 ) + PHI(I) = ATAN2( S, C ) + END IF +* + END DO +* +* Reduce the bottom-right portion of X11 to [ I 0 ] +* + DO I = M - Q + 1, P + CALL DLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) + X11(I,I) = ONE + CALL DLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL DLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X21(M-Q+1,I), LDX21, WORK(ILARF) ) + END DO +* +* Reduce the bottom-right portion of X21 to [ 0 I ] +* + DO I = P + 1, Q + CALL DLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21, + $ TAUQ1(I) ) + X21(M-Q+I-P,I) = ONE + CALL DLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I), + $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) ) + END DO +* + RETURN +* +* End of DORBDB4 +* + END + diff --git a/math/lapack/src/main/fortran/dorbdb5.f b/math/lapack/src/main/fortran/dorbdb5.f new file mode 100644 index 0000000000..de01f5a445 --- /dev/null +++ b/math/lapack/src/main/fortran/dorbdb5.f @@ -0,0 +1,274 @@ +*> \brief \b DORBDB5 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORBDB5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, +* LDQ2, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, +* $ N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> DORBDB5 orthogonalizes the column vector +*> X = [ X1 ] +*> [ X2 ] +*> with respect to the columns of +*> Q = [ Q1 ] . +*> [ Q2 ] +*> The columns of Q must be orthonormal. +*> +*> If the projection is zero according to Kahan's "twice is enough" +*> criterion, then some other vector from the orthogonal complement +*> is returned. This vector is chosen in an arbitrary but deterministic +*> way. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M1 +*> \verbatim +*> M1 is INTEGER +*> The dimension of X1 and the number of rows in Q1. 0 <= M1. +*> \endverbatim +*> +*> \param[in] M2 +*> \verbatim +*> M2 is INTEGER +*> The dimension of X2 and the number of rows in Q2. 0 <= M2. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns in Q1 and Q2. 0 <= N. +*> \endverbatim +*> +*> \param[in,out] X1 +*> \verbatim +*> X1 is DOUBLE PRECISION array, dimension (M1) +*> On entry, the top part of the vector to be orthogonalized. +*> On exit, the top part of the projected vector. +*> \endverbatim +*> +*> \param[in] INCX1 +*> \verbatim +*> INCX1 is INTEGER +*> Increment for entries of X1. +*> \endverbatim +*> +*> \param[in,out] X2 +*> \verbatim +*> X2 is DOUBLE PRECISION array, dimension (M2) +*> On entry, the bottom part of the vector to be +*> orthogonalized. On exit, the bottom part of the projected +*> vector. +*> \endverbatim +*> +*> \param[in] INCX2 +*> \verbatim +*> INCX2 is INTEGER +*> Increment for entries of X2. +*> \endverbatim +*> +*> \param[in] Q1 +*> \verbatim +*> Q1 is DOUBLE PRECISION array, dimension (LDQ1, N) +*> The top part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ1 +*> \verbatim +*> LDQ1 is INTEGER +*> The leading dimension of Q1. LDQ1 >= M1. +*> \endverbatim +*> +*> \param[in] Q2 +*> \verbatim +*> Q2 is DOUBLE PRECISION array, dimension (LDQ2, N) +*> The bottom part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ2 +*> \verbatim +*> LDQ2 is INTEGER +*> The leading dimension of Q2. LDQ2 >= M2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= N. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, + $ N +* .. +* .. Array Arguments .. + DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER CHILDINFO, I, J +* .. +* .. External Subroutines .. + EXTERNAL DORBDB6, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + IF( M1 .LT. 0 ) THEN + INFO = -1 + ELSE IF( M2 .LT. 0 ) THEN + INFO = -2 + ELSE IF( N .LT. 0 ) THEN + INFO = -3 + ELSE IF( INCX1 .LT. 1 ) THEN + INFO = -5 + ELSE IF( INCX2 .LT. 1 ) THEN + INFO = -7 + ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN + INFO = -9 + ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN + INFO = -11 + ELSE IF( LWORK .LT. N ) THEN + INFO = -13 + END IF +* + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORBDB5', -INFO ) + RETURN + END IF +* +* Project X onto the orthogonal complement of Q +* + CALL DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, LDQ2, + $ WORK, LWORK, CHILDINFO ) +* +* If the projection is nonzero, then return +* + IF( DNRM2(M1,X1,INCX1) .NE. ZERO + $ .OR. DNRM2(M2,X2,INCX2) .NE. ZERO ) THEN + RETURN + END IF +* +* Project each standard basis vector e_1,...,e_M1 in turn, stopping +* when a nonzero projection is found +* + DO I = 1, M1 + DO J = 1, M1 + X1(J) = ZERO + END DO + X1(I) = ONE + DO J = 1, M2 + X2(J) = ZERO + END DO + CALL DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, CHILDINFO ) + IF( DNRM2(M1,X1,INCX1) .NE. ZERO + $ .OR. DNRM2(M2,X2,INCX2) .NE. ZERO ) THEN + RETURN + END IF + END DO +* +* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn, +* stopping when a nonzero projection is found +* + DO I = 1, M2 + DO J = 1, M1 + X1(J) = ZERO + END DO + DO J = 1, M2 + X2(J) = ZERO + END DO + X2(I) = ONE + CALL DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, CHILDINFO ) + IF( DNRM2(M1,X1,INCX1) .NE. ZERO + $ .OR. DNRM2(M2,X2,INCX2) .NE. ZERO ) THEN + RETURN + END IF + END DO +* + RETURN +* +* End of DORBDB5 +* + END + diff --git a/math/lapack/src/main/fortran/dorbdb6.f b/math/lapack/src/main/fortran/dorbdb6.f new file mode 100644 index 0000000000..6056d0301a --- /dev/null +++ b/math/lapack/src/main/fortran/dorbdb6.f @@ -0,0 +1,312 @@ +*> \brief \b DORBDB6 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORBDB6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, +* LDQ2, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, +* $ N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> DORBDB6 orthogonalizes the column vector +*> X = [ X1 ] +*> [ X2 ] +*> with respect to the columns of +*> Q = [ Q1 ] . +*> [ Q2 ] +*> The columns of Q must be orthonormal. +*> +*> If the projection is zero according to Kahan's "twice is enough" +*> criterion, then the zero vector is returned. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M1 +*> \verbatim +*> M1 is INTEGER +*> The dimension of X1 and the number of rows in Q1. 0 <= M1. +*> \endverbatim +*> +*> \param[in] M2 +*> \verbatim +*> M2 is INTEGER +*> The dimension of X2 and the number of rows in Q2. 0 <= M2. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns in Q1 and Q2. 0 <= N. +*> \endverbatim +*> +*> \param[in,out] X1 +*> \verbatim +*> X1 is DOUBLE PRECISION array, dimension (M1) +*> On entry, the top part of the vector to be orthogonalized. +*> On exit, the top part of the projected vector. +*> \endverbatim +*> +*> \param[in] INCX1 +*> \verbatim +*> INCX1 is INTEGER +*> Increment for entries of X1. +*> \endverbatim +*> +*> \param[in,out] X2 +*> \verbatim +*> X2 is DOUBLE PRECISION array, dimension (M2) +*> On entry, the bottom part of the vector to be +*> orthogonalized. On exit, the bottom part of the projected +*> vector. +*> \endverbatim +*> +*> \param[in] INCX2 +*> \verbatim +*> INCX2 is INTEGER +*> Increment for entries of X2. +*> \endverbatim +*> +*> \param[in] Q1 +*> \verbatim +*> Q1 is DOUBLE PRECISION array, dimension (LDQ1, N) +*> The top part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ1 +*> \verbatim +*> LDQ1 is INTEGER +*> The leading dimension of Q1. LDQ1 >= M1. +*> \endverbatim +*> +*> \param[in] Q2 +*> \verbatim +*> Q2 is DOUBLE PRECISION array, dimension (LDQ2, N) +*> The bottom part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ2 +*> \verbatim +*> LDQ2 is INTEGER +*> The leading dimension of Q2. LDQ2 >= M2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= N. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, + $ N +* .. +* .. Array Arguments .. + DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ALPHASQ, REALONE, REALZERO + PARAMETER ( ALPHASQ = 0.01D0, REALONE = 1.0D0, + $ REALZERO = 0.0D0 ) + DOUBLE PRECISION NEGONE, ONE, ZERO + PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2 +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DLASSQ, XERBLA +* .. +* .. Intrinsic Function .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + IF( M1 .LT. 0 ) THEN + INFO = -1 + ELSE IF( M2 .LT. 0 ) THEN + INFO = -2 + ELSE IF( N .LT. 0 ) THEN + INFO = -3 + ELSE IF( INCX1 .LT. 1 ) THEN + INFO = -5 + ELSE IF( INCX2 .LT. 1 ) THEN + INFO = -7 + ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN + INFO = -9 + ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN + INFO = -11 + ELSE IF( LWORK .LT. N ) THEN + INFO = -13 + END IF +* + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORBDB6', -INFO ) + RETURN + END IF +* +* First, project X onto the orthogonal complement of Q's column +* space +* + SCL1 = REALZERO + SSQ1 = REALONE + CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + SCL2 = REALZERO + SSQ2 = REALONE + CALL DLASSQ( M2, X2, INCX2, SCL2, SSQ2 ) + NORMSQ1 = SCL1**2*SSQ1 + SCL2**2*SSQ2 +* + IF( M1 .EQ. 0 ) THEN + DO I = 1, N + WORK(I) = ZERO + END DO + ELSE + CALL DGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK, + $ 1 ) + END IF +* + CALL DGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 ) +* + CALL DGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1, + $ INCX1 ) + CALL DGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2, + $ INCX2 ) +* + SCL1 = REALZERO + SSQ1 = REALONE + CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + SCL2 = REALZERO + SSQ2 = REALONE + CALL DLASSQ( M2, X2, INCX2, SCL2, SSQ2 ) + NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2 +* +* If projection is sufficiently large in norm, then stop. +* If projection is zero, then stop. +* Otherwise, project again. +* + IF( NORMSQ2 .GE. ALPHASQ*NORMSQ1 ) THEN + RETURN + END IF +* + IF( NORMSQ2 .EQ. ZERO ) THEN + RETURN + END IF +* + NORMSQ1 = NORMSQ2 +* + DO I = 1, N + WORK(I) = ZERO + END DO +* + IF( M1 .EQ. 0 ) THEN + DO I = 1, N + WORK(I) = ZERO + END DO + ELSE + CALL DGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK, + $ 1 ) + END IF +* + CALL DGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 ) +* + CALL DGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1, + $ INCX1 ) + CALL DGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2, + $ INCX2 ) +* + SCL1 = REALZERO + SSQ1 = REALONE + CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + SCL2 = REALZERO + SSQ2 = REALONE + CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2 +* +* If second projection is sufficiently large in norm, then do +* nothing more. Alternatively, if it shrunk significantly, then +* truncate it to zero. +* + IF( NORMSQ2 .LT. ALPHASQ*NORMSQ1 ) THEN + DO I = 1, M1 + X1(I) = ZERO + END DO + DO I = 1, M2 + X2(I) = ZERO + END DO + END IF +* + RETURN +* +* End of DORBDB6 +* + END + diff --git a/math/lapack/src/main/fortran/dorcsd.f b/math/lapack/src/main/fortran/dorcsd.f new file mode 100644 index 0000000000..340e16a5d6 --- /dev/null +++ b/math/lapack/src/main/fortran/dorcsd.f @@ -0,0 +1,616 @@ +*> \brief \b DORCSD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORCSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* RECURSIVE SUBROUTINE DORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, +* SIGNS, M, P, Q, X11, LDX11, X12, +* LDX12, X21, LDX21, X22, LDX22, THETA, +* U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, +* LDV2T, WORK, LWORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS +* INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LDX11, LDX12, +* $ LDX21, LDX22, LWORK, M, P, Q +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION THETA( * ) +* DOUBLE PRECISION U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), +* $ V2T( LDV2T, * ), WORK( * ), X11( LDX11, * ), +* $ X12( LDX12, * ), X21( LDX21, * ), X22( LDX22, +* $ * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORCSD computes the CS decomposition of an M-by-M partitioned +*> orthogonal matrix X: +*> +*> [ I 0 0 | 0 0 0 ] +*> [ 0 C 0 | 0 -S 0 ] +*> [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**T +*> X = [-----------] = [---------] [---------------------] [---------] . +*> [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ] +*> [ 0 S 0 | 0 C 0 ] +*> [ 0 0 I | 0 0 0 ] +*> +*> X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P, +*> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are +*> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in +*> which R = MIN(P,M-P,Q,M-Q). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBU1 +*> \verbatim +*> JOBU1 is CHARACTER +*> = 'Y': U1 is computed; +*> otherwise: U1 is not computed. +*> \endverbatim +*> +*> \param[in] JOBU2 +*> \verbatim +*> JOBU2 is CHARACTER +*> = 'Y': U2 is computed; +*> otherwise: U2 is not computed. +*> \endverbatim +*> +*> \param[in] JOBV1T +*> \verbatim +*> JOBV1T is CHARACTER +*> = 'Y': V1T is computed; +*> otherwise: V1T is not computed. +*> \endverbatim +*> +*> \param[in] JOBV2T +*> \verbatim +*> JOBV2T is CHARACTER +*> = 'Y': V2T is computed; +*> otherwise: V2T is not computed. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER +*> = 'T': X, U1, U2, V1T, and V2T are stored in row-major +*> order; +*> otherwise: X, U1, U2, V1T, and V2T are stored in column- +*> major order. +*> \endverbatim +*> +*> \param[in] SIGNS +*> \verbatim +*> SIGNS is CHARACTER +*> = 'O': The lower-left block is made nonpositive (the +*> "other" convention); +*> otherwise: The upper-right block is made nonpositive (the +*> "default" convention). +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows and columns in X. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11 and X12. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, part of the orthogonal matrix whose CSD is desired. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= MAX(1,P). +*> \endverbatim +*> +*> \param[in,out] X12 +*> \verbatim +*> X12 is DOUBLE PRECISION array, dimension (LDX12,M-Q) +*> On entry, part of the orthogonal matrix whose CSD is desired. +*> \endverbatim +*> +*> \param[in] LDX12 +*> \verbatim +*> LDX12 is INTEGER +*> The leading dimension of X12. LDX12 >= MAX(1,P). +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, part of the orthogonal matrix whose CSD is desired. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X11. LDX21 >= MAX(1,M-P). +*> \endverbatim +*> +*> \param[in,out] X22 +*> \verbatim +*> X22 is DOUBLE PRECISION array, dimension (LDX22,M-Q) +*> On entry, part of the orthogonal matrix whose CSD is desired. +*> \endverbatim +*> +*> \param[in] LDX22 +*> \verbatim +*> LDX22 is INTEGER +*> The leading dimension of X11. LDX22 >= MAX(1,M-P). +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (R), in which R = +*> MIN(P,M-P,Q,M-Q). +*> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and +*> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ). +*> \endverbatim +*> +*> \param[out] U1 +*> \verbatim +*> U1 is DOUBLE PRECISION array, dimension (P) +*> If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1. +*> \endverbatim +*> +*> \param[in] LDU1 +*> \verbatim +*> LDU1 is INTEGER +*> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >= +*> MAX(1,P). +*> \endverbatim +*> +*> \param[out] U2 +*> \verbatim +*> U2 is DOUBLE PRECISION array, dimension (M-P) +*> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal +*> matrix U2. +*> \endverbatim +*> +*> \param[in] LDU2 +*> \verbatim +*> LDU2 is INTEGER +*> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >= +*> MAX(1,M-P). +*> \endverbatim +*> +*> \param[out] V1T +*> \verbatim +*> V1T is DOUBLE PRECISION array, dimension (Q) +*> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal +*> matrix V1**T. +*> \endverbatim +*> +*> \param[in] LDV1T +*> \verbatim +*> LDV1T is INTEGER +*> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >= +*> MAX(1,Q). +*> \endverbatim +*> +*> \param[out] V2T +*> \verbatim +*> V2T is DOUBLE PRECISION array, dimension (M-Q) +*> If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) orthogonal +*> matrix V2**T. +*> \endverbatim +*> +*> \param[in] LDV2T +*> \verbatim +*> LDV2T is INTEGER +*> The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >= +*> MAX(1,M-Q). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1), +*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R), +*> define the matrix in intermediate bidiagonal-block form +*> remaining after nonconvergence. INFO specifies the number +*> of nonzero PHI's. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the work array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (M-MIN(P, M-P, Q, M-Q)) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: DBBCSD did not converge. See the description of WORK +*> above for details. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + RECURSIVE SUBROUTINE DORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, + $ SIGNS, M, P, Q, X11, LDX11, X12, + $ LDX12, X21, LDX21, X22, LDX22, THETA, + $ U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, + $ LDV2T, WORK, LWORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS + INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LDX11, LDX12, + $ LDX21, LDX22, LWORK, M, P, Q +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION THETA( * ) + DOUBLE PRECISION U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), + $ V2T( LDV2T, * ), WORK( * ), X11( LDX11, * ), + $ X12( LDX12, * ), X21( LDX21, * ), X22( LDX22, + $ * ) +* .. +* +* =================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, + $ ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + CHARACTER TRANST, SIGNST + INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E, + $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB, + $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1, + $ ITAUQ2, J, LBBCSDWORK, LBBCSDWORKMIN, + $ LBBCSDWORKOPT, LORBDBWORK, LORBDBWORKMIN, + $ LORBDBWORKOPT, LORGLQWORK, LORGLQWORKMIN, + $ LORGLQWORKOPT, LORGQRWORK, LORGQRWORKMIN, + $ LORGQRWORKOPT, LWORKMIN, LWORKOPT + LOGICAL COLMAJOR, DEFAULTSIGNS, LQUERY, WANTU1, WANTU2, + $ WANTV1T, WANTV2T +* .. +* .. External Subroutines .. + EXTERNAL DBBCSD, DLACPY, DLAPMR, DLAPMT, + $ DORBDB, DORGLQ, DORGQR, XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions + INTRINSIC INT, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + WANTU1 = LSAME( JOBU1, 'Y' ) + WANTU2 = LSAME( JOBU2, 'Y' ) + WANTV1T = LSAME( JOBV1T, 'Y' ) + WANTV2T = LSAME( JOBV2T, 'Y' ) + COLMAJOR = .NOT. LSAME( TRANS, 'T' ) + DEFAULTSIGNS = .NOT. LSAME( SIGNS, 'O' ) + LQUERY = LWORK .EQ. -1 + IF( M .LT. 0 ) THEN + INFO = -7 + ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN + INFO = -8 + ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN + INFO = -9 + ELSE IF ( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF (.NOT. COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN + INFO = -11 + ELSE IF (COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF (.NOT. COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN + INFO = -13 + ELSE IF (COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -15 + ELSE IF (.NOT. COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN + INFO = -15 + ELSE IF (COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN + INFO = -17 + ELSE IF (.NOT. COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN + INFO = -17 + ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN + INFO = -20 + ELSE IF( WANTU2 .AND. LDU2 .LT. M-P ) THEN + INFO = -22 + ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN + INFO = -24 + ELSE IF( WANTV2T .AND. LDV2T .LT. M-Q ) THEN + INFO = -26 + END IF +* +* Work with transpose if convenient +* + IF( INFO .EQ. 0 .AND. MIN( P, M-P ) .LT. MIN( Q, M-Q ) ) THEN + IF( COLMAJOR ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF + IF( DEFAULTSIGNS ) THEN + SIGNST = 'O' + ELSE + SIGNST = 'D' + END IF + CALL DORCSD( JOBV1T, JOBV2T, JOBU1, JOBU2, TRANST, SIGNST, M, + $ Q, P, X11, LDX11, X21, LDX21, X12, LDX12, X22, + $ LDX22, THETA, V1T, LDV1T, V2T, LDV2T, U1, LDU1, + $ U2, LDU2, WORK, LWORK, IWORK, INFO ) + RETURN + END IF +* +* Work with permutation [ 0 I; I 0 ] * X * [ 0 I; I 0 ] if +* convenient +* + IF( INFO .EQ. 0 .AND. M-Q .LT. Q ) THEN + IF( DEFAULTSIGNS ) THEN + SIGNST = 'O' + ELSE + SIGNST = 'D' + END IF + CALL DORCSD( JOBU2, JOBU1, JOBV2T, JOBV1T, TRANS, SIGNST, M, + $ M-P, M-Q, X22, LDX22, X21, LDX21, X12, LDX12, X11, + $ LDX11, THETA, U2, LDU2, U1, LDU1, V2T, LDV2T, V1T, + $ LDV1T, WORK, LWORK, IWORK, INFO ) + RETURN + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN +* + IPHI = 2 + ITAUP1 = IPHI + MAX( 1, Q - 1 ) + ITAUP2 = ITAUP1 + MAX( 1, P ) + ITAUQ1 = ITAUP2 + MAX( 1, M - P ) + ITAUQ2 = ITAUQ1 + MAX( 1, Q ) + IORGQR = ITAUQ2 + MAX( 1, M - Q ) + CALL DORGQR( M-Q, M-Q, M-Q, U1, MAX(1,M-Q), U1, WORK, -1, + $ CHILDINFO ) + LORGQRWORKOPT = INT( WORK(1) ) + LORGQRWORKMIN = MAX( 1, M - Q ) + IORGLQ = ITAUQ2 + MAX( 1, M - Q ) + CALL DORGLQ( M-Q, M-Q, M-Q, U1, MAX(1,M-Q), U1, WORK, -1, + $ CHILDINFO ) + LORGLQWORKOPT = INT( WORK(1) ) + LORGLQWORKMIN = MAX( 1, M - Q ) + IORBDB = ITAUQ2 + MAX( 1, M - Q ) + CALL DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, + $ X21, LDX21, X22, LDX22, THETA, V1T, U1, U2, V1T, + $ V2T, WORK, -1, CHILDINFO ) + LORBDBWORKOPT = INT( WORK(1) ) + LORBDBWORKMIN = LORBDBWORKOPT + IB11D = ITAUQ2 + MAX( 1, M - Q ) + IB11E = IB11D + MAX( 1, Q ) + IB12D = IB11E + MAX( 1, Q - 1 ) + IB12E = IB12D + MAX( 1, Q ) + IB21D = IB12E + MAX( 1, Q - 1 ) + IB21E = IB21D + MAX( 1, Q ) + IB22D = IB21E + MAX( 1, Q - 1 ) + IB22E = IB22D + MAX( 1, Q ) + IBBCSD = IB22E + MAX( 1, Q - 1 ) + CALL DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, + $ THETA, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, + $ LDV2T, U1, U1, U1, U1, U1, U1, U1, U1, WORK, -1, + $ CHILDINFO ) + LBBCSDWORKOPT = INT( WORK(1) ) + LBBCSDWORKMIN = LBBCSDWORKOPT + LWORKOPT = MAX( IORGQR + LORGQRWORKOPT, IORGLQ + LORGLQWORKOPT, + $ IORBDB + LORBDBWORKOPT, IBBCSD + LBBCSDWORKOPT ) - 1 + LWORKMIN = MAX( IORGQR + LORGQRWORKMIN, IORGLQ + LORGLQWORKMIN, + $ IORBDB + LORBDBWORKOPT, IBBCSD + LBBCSDWORKMIN ) - 1 + WORK(1) = MAX(LWORKOPT,LWORKMIN) +* + IF( LWORK .LT. LWORKMIN .AND. .NOT. LQUERY ) THEN + INFO = -22 + ELSE + LORGQRWORK = LWORK - IORGQR + 1 + LORGLQWORK = LWORK - IORGLQ + 1 + LORBDBWORK = LWORK - IORBDB + 1 + LBBCSDWORK = LWORK - IBBCSD + 1 + END IF + END IF +* +* Abort if any illegal arguments +* + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORCSD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Transform to bidiagonal block form +* + CALL DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, + $ LDX21, X22, LDX22, THETA, WORK(IPHI), WORK(ITAUP1), + $ WORK(ITAUP2), WORK(ITAUQ1), WORK(ITAUQ2), + $ WORK(IORBDB), LORBDBWORK, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( COLMAJOR ) THEN + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL DLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 ) + CALL DORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR), + $ LORGQRWORK, INFO) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL DLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 ) + CALL DORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGQR), LORGQRWORK, INFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL DLACPY( 'U', Q-1, Q-1, X11(1,2), LDX11, V1T(2,2), + $ LDV1T ) + V1T(1, 1) = ONE + DO J = 2, Q + V1T(1,J) = ZERO + V1T(J,1) = ZERO + END DO + CALL DORGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQWORK, INFO ) + END IF + IF( WANTV2T .AND. M-Q .GT. 0 ) THEN + CALL DLACPY( 'U', P, M-Q, X12, LDX12, V2T, LDV2T ) + IF (M-P .GT. Q) Then + CALL DLACPY( 'U', M-P-Q, M-P-Q, X22(Q+1,P+1), LDX22, + $ V2T(P+1,P+1), LDV2T ) + END IF + IF (M .GT. Q) THEN + CALL DORGLQ( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2), + $ WORK(IORGLQ), LORGLQWORK, INFO ) + END IF + END IF + ELSE + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL DLACPY( 'U', Q, P, X11, LDX11, U1, LDU1 ) + CALL DORGLQ( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGLQ), + $ LORGLQWORK, INFO) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL DLACPY( 'U', Q, M-P, X21, LDX21, U2, LDU2 ) + CALL DORGLQ( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGLQ), LORGLQWORK, INFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL DLACPY( 'L', Q-1, Q-1, X11(2,1), LDX11, V1T(2,2), + $ LDV1T ) + V1T(1, 1) = ONE + DO J = 2, Q + V1T(1,J) = ZERO + V1T(J,1) = ZERO + END DO + CALL DORGQR( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1), + $ WORK(IORGQR), LORGQRWORK, INFO ) + END IF + IF( WANTV2T .AND. M-Q .GT. 0 ) THEN + CALL DLACPY( 'L', M-Q, P, X12, LDX12, V2T, LDV2T ) + CALL DLACPY( 'L', M-P-Q, M-P-Q, X22(P+1,Q+1), LDX22, + $ V2T(P+1,P+1), LDV2T ) + CALL DORGQR( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2), + $ WORK(IORGQR), LORGQRWORK, INFO ) + END IF + END IF +* +* Compute the CSD of the matrix in bidiagonal-block form +* + CALL DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, + $ WORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, + $ LDV2T, WORK(IB11D), WORK(IB11E), WORK(IB12D), + $ WORK(IB12E), WORK(IB21D), WORK(IB21E), WORK(IB22D), + $ WORK(IB22E), WORK(IBBCSD), LBBCSDWORK, INFO ) +* +* Permute rows and columns to place identity submatrices in top- +* left corner of (1,1)-block and/or bottom-right corner of (1,2)- +* block and/or bottom-right corner of (2,1)-block and/or top-left +* corner of (2,2)-block +* + IF( Q .GT. 0 .AND. WANTU2 ) THEN + DO I = 1, Q + IWORK(I) = M - P - Q + I + END DO + DO I = Q + 1, M - P + IWORK(I) = I - Q + END DO + IF( COLMAJOR ) THEN + CALL DLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK ) + ELSE + CALL DLAPMR( .FALSE., M-P, M-P, U2, LDU2, IWORK ) + END IF + END IF + IF( M .GT. 0 .AND. WANTV2T ) THEN + DO I = 1, P + IWORK(I) = M - P - Q + I + END DO + DO I = P + 1, M - Q + IWORK(I) = I - P + END DO + IF( .NOT. COLMAJOR ) THEN + CALL DLAPMT( .FALSE., M-Q, M-Q, V2T, LDV2T, IWORK ) + ELSE + CALL DLAPMR( .FALSE., M-Q, M-Q, V2T, LDV2T, IWORK ) + END IF + END IF +* + RETURN +* +* End DORCSD +* + END + diff --git a/math/lapack/src/main/fortran/dorcsd2by1.f b/math/lapack/src/main/fortran/dorcsd2by1.f new file mode 100644 index 0000000000..8542a2ed35 --- /dev/null +++ b/math/lapack/src/main/fortran/dorcsd2by1.f @@ -0,0 +1,740 @@ +*> \brief \b DORCSD2BY1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORCSD2BY1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, +* X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T, +* LDV1T, WORK, LWORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBU1, JOBU2, JOBV1T +* INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21, +* $ M, P, Q +* .. +* .. Array Arguments .. +* DOUBLE PRECISION THETA(*) +* DOUBLE PRECISION U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* INTEGER IWORK(*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> DORCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with +*> orthonormal columns that has been partitioned into a 2-by-1 block +*> structure: +*> +*> [ I1 0 0 ] +*> [ 0 C 0 ] +*> [ X11 ] [ U1 | ] [ 0 0 0 ] +*> X = [-----] = [---------] [----------] V1**T . +*> [ X21 ] [ | U2 ] [ 0 0 0 ] +*> [ 0 S 0 ] +*> [ 0 0 I2] +*> +*> X11 is P-by-Q. The orthogonal matrices U1, U2, and V1 are P-by-P, +*> (M-P)-by-(M-P), and Q-by-Q, respectively. C and S are R-by-R +*> nonnegative diagonal matrices satisfying C^2 + S^2 = I, in which +*> R = MIN(P,M-P,Q,M-Q). I1 is a K1-by-K1 identity matrix and I2 is a +*> K2-by-K2 identity matrix, where K1 = MAX(Q+P-M,0), K2 = MAX(Q-P,0). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBU1 +*> \verbatim +*> JOBU1 is CHARACTER +*> = 'Y': U1 is computed; +*> otherwise: U1 is not computed. +*> \endverbatim +*> +*> \param[in] JOBU2 +*> \verbatim +*> JOBU2 is CHARACTER +*> = 'Y': U2 is computed; +*> otherwise: U2 is not computed. +*> \endverbatim +*> +*> \param[in] JOBV1T +*> \verbatim +*> JOBV1T is CHARACTER +*> = 'Y': V1T is computed; +*> otherwise: V1T is not computed. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows in X. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, part of the orthogonal matrix whose CSD is desired. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= MAX(1,P). +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, part of the orthogonal matrix whose CSD is desired. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= MAX(1,M-P). +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (R), in which R = +*> MIN(P,M-P,Q,M-Q). +*> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and +*> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ). +*> \endverbatim +*> +*> \param[out] U1 +*> \verbatim +*> U1 is DOUBLE PRECISION array, dimension (P) +*> If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1. +*> \endverbatim +*> +*> \param[in] LDU1 +*> \verbatim +*> LDU1 is INTEGER +*> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >= +*> MAX(1,P). +*> \endverbatim +*> +*> \param[out] U2 +*> \verbatim +*> U2 is DOUBLE PRECISION array, dimension (M-P) +*> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal +*> matrix U2. +*> \endverbatim +*> +*> \param[in] LDU2 +*> \verbatim +*> LDU2 is INTEGER +*> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >= +*> MAX(1,M-P). +*> \endverbatim +*> +*> \param[out] V1T +*> \verbatim +*> V1T is DOUBLE PRECISION array, dimension (Q) +*> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal +*> matrix V1**T. +*> \endverbatim +*> +*> \param[in] LDV1T +*> \verbatim +*> LDV1T is INTEGER +*> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >= +*> MAX(1,Q). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1), +*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R), +*> define the matrix in intermediate bidiagonal-block form +*> remaining after nonconvergence. INFO specifies the number +*> of nonzero PHI's. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the work array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q)) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: DBBCSD did not converge. See the description of WORK +*> above for details. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, + $ X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T, + $ LDV1T, WORK, LWORK, IWORK, INFO ) +* +* -- LAPACK computational routine (3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + CHARACTER JOBU1, JOBU2, JOBV1T + INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21, + $ M, P, Q +* .. +* .. Array Arguments .. + DOUBLE PRECISION THETA(*) + DOUBLE PRECISION U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) + INTEGER IWORK(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E, + $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB, + $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1, + $ J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN, + $ LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT, + $ LWORKMIN, LWORKOPT, R + LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T +* .. +* .. Local Arrays .. + DOUBLE PRECISION DUM1(1), DUM2(1,1) +* .. +* .. External Subroutines .. + EXTERNAL DBBCSD, DCOPY, DLACPY, DLAPMR, DLAPMT, DORBDB1, + $ DORBDB2, DORBDB3, DORBDB4, DORGLQ, DORGQR, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Function .. + INTRINSIC INT, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + WANTU1 = LSAME( JOBU1, 'Y' ) + WANTU2 = LSAME( JOBU2, 'Y' ) + WANTV1T = LSAME( JOBV1T, 'Y' ) + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -4 + ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN + INFO = -5 + ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN + INFO = -6 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -8 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -10 + ELSE IF( WANTU1 .AND. LDU1 .LT. MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( WANTU2 .AND. LDU2 .LT. MAX( 1, M - P ) ) THEN + INFO = -15 + ELSE IF( WANTV1T .AND. LDV1T .LT. MAX( 1, Q ) ) THEN + INFO = -17 + END IF +* + R = MIN( P, M-P, Q, M-Q ) +* +* Compute workspace +* +* WORK layout: +* |-------------------------------------------------------| +* | LWORKOPT (1) | +* |-------------------------------------------------------| +* | PHI (MAX(1,R-1)) | +* |-------------------------------------------------------| +* | TAUP1 (MAX(1,P)) | B11D (R) | +* | TAUP2 (MAX(1,M-P)) | B11E (R-1) | +* | TAUQ1 (MAX(1,Q)) | B12D (R) | +* |-----------------------------------------| B12E (R-1) | +* | DORBDB WORK | DORGQR WORK | DORGLQ WORK | B21D (R) | +* | | | | B21E (R-1) | +* | | | | B22D (R) | +* | | | | B22E (R-1) | +* | | | | DBBCSD WORK | +* |-------------------------------------------------------| +* + IF( INFO .EQ. 0 ) THEN + IPHI = 2 + IB11D = IPHI + MAX( 1, R-1 ) + IB11E = IB11D + MAX( 1, R ) + IB12D = IB11E + MAX( 1, R - 1 ) + IB12E = IB12D + MAX( 1, R ) + IB21D = IB12E + MAX( 1, R - 1 ) + IB21E = IB21D + MAX( 1, R ) + IB22D = IB21E + MAX( 1, R - 1 ) + IB22E = IB22D + MAX( 1, R ) + IBBCSD = IB22E + MAX( 1, R - 1 ) + ITAUP1 = IPHI + MAX( 1, R-1 ) + ITAUP2 = ITAUP1 + MAX( 1, P ) + ITAUQ1 = ITAUP2 + MAX( 1, M-P ) + IORBDB = ITAUQ1 + MAX( 1, Q ) + IORGQR = ITAUQ1 + MAX( 1, Q ) + IORGLQ = ITAUQ1 + MAX( 1, Q ) + LORGQRMIN = 1 + LORGQROPT = 1 + LORGLQMIN = 1 + LORGLQOPT = 1 + IF( R .EQ. Q ) THEN + CALL DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ DUM1, DUM1, DUM1, DUM1, WORK, + $ -1, CHILDINFO ) + LORBDB = INT( WORK(1) ) + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL DORGQR( P, P, Q, U1, LDU1, DUM1, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( LORGQRMIN, P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + ENDIF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL DORGQR( M-P, M-P, Q, U2, LDU2, DUM1, WORK(1), + $ -1, CHILDINFO ) + LORGQRMIN = MAX( LORGQRMIN, M-P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL DORGLQ( Q-1, Q-1, Q-1, V1T, LDV1T, + $ DUM1, WORK(1), -1, CHILDINFO ) + LORGLQMIN = MAX( LORGLQMIN, Q-1 ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) + END IF + CALL DBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, + $ DUM1, U1, LDU1, U2, LDU2, V1T, LDV1T, + $ DUM2, 1, DUM1, DUM1, DUM1, + $ DUM1, DUM1, DUM1, DUM1, + $ DUM1, WORK(1), -1, CHILDINFO ) + LBBCSD = INT( WORK(1) ) + ELSE IF( R .EQ. P ) THEN + CALL DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ DUM1, DUM1, DUM1, DUM1, + $ WORK(1), -1, CHILDINFO ) + LORBDB = INT( WORK(1) ) + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL DORGQR( P-1, P-1, P-1, U1(2,2), LDU1, DUM1, + $ WORK(1), -1, CHILDINFO ) + LORGQRMIN = MAX( LORGQRMIN, P-1 ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL DORGQR( M-P, M-P, Q, U2, LDU2, DUM1, WORK(1), + $ -1, CHILDINFO ) + LORGQRMIN = MAX( LORGQRMIN, M-P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL DORGLQ( Q, Q, R, V1T, LDV1T, DUM1, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( LORGLQMIN, Q ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) + END IF + CALL DBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, + $ DUM1, V1T, LDV1T, DUM2, 1, U1, LDU1, + $ U2, LDU2, DUM1, DUM1, DUM1, + $ DUM1, DUM1, DUM1, DUM1, + $ DUM1, WORK(1), -1, CHILDINFO ) + LBBCSD = INT( WORK(1) ) + ELSE IF( R .EQ. M-P ) THEN + CALL DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ DUM1, DUM1, DUM1, DUM1, + $ WORK(1), -1, CHILDINFO ) + LORBDB = INT( WORK(1) ) + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL DORGQR( P, P, Q, U1, LDU1, DUM1, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( LORGQRMIN, P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL DORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, + $ DUM1, WORK(1), -1, CHILDINFO ) + LORGQRMIN = MAX( LORGQRMIN, M-P-1 ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL DORGLQ( Q, Q, R, V1T, LDV1T, DUM1, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( LORGLQMIN, Q ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) + END IF + CALL DBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, + $ THETA, DUM1, DUM2, 1, V1T, LDV1T, U2, + $ LDU2, U1, LDU1, DUM1, DUM1, DUM1, + $ DUM1, DUM1, DUM1, DUM1, + $ DUM1, WORK(1), -1, CHILDINFO ) + LBBCSD = INT( WORK(1) ) + ELSE + CALL DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ DUM1, DUM1, DUM1, DUM1, + $ DUM1, WORK(1), -1, CHILDINFO ) + LORBDB = M + INT( WORK(1) ) + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL DORGQR( P, P, M-Q, U1, LDU1, DUM1, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( LORGQRMIN, P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL DORGQR( M-P, M-P, M-Q, U2, LDU2, DUM1, WORK(1), + $ -1, CHILDINFO ) + LORGQRMIN = MAX( LORGQRMIN, M-P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL DORGLQ( Q, Q, Q, V1T, LDV1T, DUM1, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( LORGLQMIN, Q ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) + END IF + CALL DBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, + $ THETA, DUM1, U2, LDU2, U1, LDU1, DUM2, + $ 1, V1T, LDV1T, DUM1, DUM1, DUM1, + $ DUM1, DUM1, DUM1, DUM1, + $ DUM1, WORK(1), -1, CHILDINFO ) + LBBCSD = INT( WORK(1) ) + END IF + LWORKMIN = MAX( IORBDB+LORBDB-1, + $ IORGQR+LORGQRMIN-1, + $ IORGLQ+LORGLQMIN-1, + $ IBBCSD+LBBCSD-1 ) + LWORKOPT = MAX( IORBDB+LORBDB-1, + $ IORGQR+LORGQROPT-1, + $ IORGLQ+LORGLQOPT-1, + $ IBBCSD+LBBCSD-1 ) + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -19 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORCSD2BY1', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF + LORGQR = LWORK-IORGQR+1 + LORGLQ = LWORK-IORGLQ+1 +* +* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q, +* in which R = MIN(P,M-P,Q,M-Q) +* + IF( R .EQ. Q ) THEN +* +* Case 1: R = Q +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL DLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 ) + CALL DORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR), + $ LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL DLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 ) + CALL DORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + V1T(1,1) = ONE + DO J = 2, Q + V1T(1,J) = ZERO + V1T(J,1) = ZERO + END DO + CALL DLACPY( 'U', Q-1, Q-1, X21(1,2), LDX21, V1T(2,2), + $ LDV1T ) + CALL DORGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL DBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, + $ WORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, + $ DUM2, 1, WORK(IB11D), WORK(IB11E), + $ WORK(IB12D), WORK(IB12E), WORK(IB21D), + $ WORK(IB21E), WORK(IB22D), WORK(IB22E), + $ WORK(IBBCSD), LBBCSD, CHILDINFO ) +* +* Permute rows and columns to place zero submatrices in +* preferred positions +* + IF( Q .GT. 0 .AND. WANTU2 ) THEN + DO I = 1, Q + IWORK(I) = M - P - Q + I + END DO + DO I = Q + 1, M - P + IWORK(I) = I - Q + END DO + CALL DLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK ) + END IF + ELSE IF( R .EQ. P ) THEN +* +* Case 2: R = P +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + U1(1,1) = ONE + DO J = 2, P + U1(1,J) = ZERO + U1(J,1) = ZERO + END DO + CALL DLACPY( 'L', P-1, P-1, X11(2,1), LDX11, U1(2,2), LDU1 ) + CALL DORGQR( P-1, P-1, P-1, U1(2,2), LDU1, WORK(ITAUP1), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL DLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 ) + CALL DORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL DLACPY( 'U', P, Q, X11, LDX11, V1T, LDV1T ) + CALL DORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL DBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, + $ WORK(IPHI), V1T, LDV1T, DUM2, 1, U1, LDU1, U2, + $ LDU2, WORK(IB11D), WORK(IB11E), WORK(IB12D), + $ WORK(IB12E), WORK(IB21D), WORK(IB21E), + $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, + $ CHILDINFO ) +* +* Permute rows and columns to place identity submatrices in +* preferred positions +* + IF( Q .GT. 0 .AND. WANTU2 ) THEN + DO I = 1, Q + IWORK(I) = M - P - Q + I + END DO + DO I = Q + 1, M - P + IWORK(I) = I - Q + END DO + CALL DLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK ) + END IF + ELSE IF( R .EQ. M-P ) THEN +* +* Case 3: R = M-P +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL DLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 ) + CALL DORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR), + $ LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + U2(1,1) = ONE + DO J = 2, M-P + U2(1,J) = ZERO + U2(J,1) = ZERO + END DO + CALL DLACPY( 'L', M-P-1, M-P-1, X21(2,1), LDX21, U2(2,2), + $ LDU2 ) + CALL DORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, + $ WORK(ITAUP2), WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL DLACPY( 'U', M-P, Q, X21, LDX21, V1T, LDV1T ) + CALL DORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL DBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, + $ THETA, WORK(IPHI), DUM2, 1, V1T, LDV1T, U2, + $ LDU2, U1, LDU1, WORK(IB11D), WORK(IB11E), + $ WORK(IB12D), WORK(IB12E), WORK(IB21D), + $ WORK(IB21E), WORK(IB22D), WORK(IB22E), + $ WORK(IBBCSD), LBBCSD, CHILDINFO ) +* +* Permute rows and columns to place identity submatrices in +* preferred positions +* + IF( Q .GT. R ) THEN + DO I = 1, R + IWORK(I) = Q - R + I + END DO + DO I = R + 1, Q + IWORK(I) = I - R + END DO + IF( WANTU1 ) THEN + CALL DLAPMT( .FALSE., P, Q, U1, LDU1, IWORK ) + END IF + IF( WANTV1T ) THEN + CALL DLAPMR( .FALSE., Q, Q, V1T, LDV1T, IWORK ) + END IF + END IF + ELSE +* +* Case 4: R = M-Q +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), WORK(IORBDB+M), + $ LORBDB-M, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL DCOPY( P, WORK(IORBDB), 1, U1, 1 ) + DO J = 2, P + U1(1,J) = ZERO + END DO + CALL DLACPY( 'L', P-1, M-Q-1, X11(2,1), LDX11, U1(2,2), + $ LDU1 ) + CALL DORGQR( P, P, M-Q, U1, LDU1, WORK(ITAUP1), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL DCOPY( M-P, WORK(IORBDB+P), 1, U2, 1 ) + DO J = 2, M-P + U2(1,J) = ZERO + END DO + CALL DLACPY( 'L', M-P-1, M-Q-1, X21(2,1), LDX21, U2(2,2), + $ LDU2 ) + CALL DORGQR( M-P, M-P, M-Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL DLACPY( 'U', M-Q, Q, X21, LDX21, V1T, LDV1T ) + CALL DLACPY( 'U', P-(M-Q), Q-(M-Q), X11(M-Q+1,M-Q+1), LDX11, + $ V1T(M-Q+1,M-Q+1), LDV1T ) + CALL DLACPY( 'U', -P+Q, Q-P, X21(M-Q+1,P+1), LDX21, + $ V1T(P+1,P+1), LDV1T ) + CALL DORGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL DBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, + $ THETA, WORK(IPHI), U2, LDU2, U1, LDU1, DUM2, + $ 1, V1T, LDV1T, WORK(IB11D), WORK(IB11E), + $ WORK(IB12D), WORK(IB12E), WORK(IB21D), + $ WORK(IB21E), WORK(IB22D), WORK(IB22E), + $ WORK(IBBCSD), LBBCSD, CHILDINFO ) +* +* Permute rows and columns to place identity submatrices in +* preferred positions +* + IF( P .GT. R ) THEN + DO I = 1, R + IWORK(I) = P - R + I + END DO + DO I = R + 1, P + IWORK(I) = I - R + END DO + IF( WANTU1 ) THEN + CALL DLAPMT( .FALSE., P, P, U1, LDU1, IWORK ) + END IF + IF( WANTV1T ) THEN + CALL DLAPMR( .FALSE., P, Q, V1T, LDV1T, IWORK ) + END IF + END IF + END IF +* + RETURN +* +* End of DORCSD2BY1 +* + END + diff --git a/math/lapack/src/main/fortran/dorg2l.f b/math/lapack/src/main/fortran/dorg2l.f new file mode 100644 index 0000000000..36ff4e5d4b --- /dev/null +++ b/math/lapack/src/main/fortran/dorg2l.f @@ -0,0 +1,198 @@ +*> \brief \b DORG2L generates all or part of the orthogonal matrix Q from a QL factorization determined by sgeqlf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORG2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORG2L generates an m by n real matrix Q with orthonormal columns, +*> which is defined as the last n columns of a product of k elementary +*> reflectors of order m +*> +*> Q = H(k) . . . H(2) H(1) +*> +*> as returned by DGEQLF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. N >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the (n-k+i)-th column must contain the vector which +*> defines the elementary reflector H(i), for i = 1,2,...,k, as +*> returned by DGEQLF in the last k columns of its array +*> argument A. +*> On exit, the m by n matrix Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEQLF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, II, J, L +* .. +* .. External Subroutines .. + EXTERNAL 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/math/lapack/src/main/fortran/dorg2r.f b/math/lapack/src/main/fortran/dorg2r.f new file mode 100644 index 0000000000..4b71011a9f --- /dev/null +++ b/math/lapack/src/main/fortran/dorg2r.f @@ -0,0 +1,200 @@ +*> \brief \b DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORG2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORG2R generates an m by n real matrix Q with orthonormal columns, +*> which is defined as the first n columns of a product of k elementary +*> reflectors of order m +*> +*> Q = H(1) H(2) . . . H(k) +*> +*> as returned by DGEQRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. N >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the i-th column must contain the vector which +*> defines the elementary reflector H(i), for i = 1,2,...,k, as +*> returned by DGEQRF in the first k columns of its array +*> argument A. +*> On exit, the m-by-n matrix Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEQRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL 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/math/lapack/src/main/fortran/dorgbr.f b/math/lapack/src/main/fortran/dorgbr.f new file mode 100644 index 0000000000..cfebda5abd --- /dev/null +++ b/math/lapack/src/main/fortran/dorgbr.f @@ -0,0 +1,337 @@ +*> \brief \b DORGBR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORGBR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER VECT +* INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] VECT +*> \verbatim +*> VECT is 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. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q or P**T to be returned. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is 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). +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is 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. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is 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. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleGBcomputational +* +* ===================================================================== + SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER VECT + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. 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 + WORK( 1 ) = 1 + IF( WANTQ ) THEN + IF( M.GE.K ) THEN + CALL DORGQR( M, N, K, A, LDA, TAU, WORK, -1, IINFO ) + ELSE + IF( M.GT.1 ) THEN + CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, + $ -1, IINFO ) + END IF + END IF + ELSE + IF( K.LT.N ) THEN + CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, -1, IINFO ) + ELSE + IF( N.GT.1 ) THEN + CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, + $ -1, IINFO ) + END IF + END IF + END IF + LWKOPT = WORK( 1 ) + LWKOPT = MAX (LWKOPT, MN) + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGBR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + WORK( 1 ) = LWKOPT + 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**T, 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**T 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**T(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/math/lapack/src/main/fortran/dorghr.f b/math/lapack/src/main/fortran/dorghr.f new file mode 100644 index 0000000000..7f60c68540 --- /dev/null +++ b/math/lapack/src/main/fortran/dorghr.f @@ -0,0 +1,240 @@ +*> \brief \b DORGHR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORGHR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix Q. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is 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. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-1) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEHRD. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dorgl2.f b/math/lapack/src/main/fortran/dorgl2.f new file mode 100644 index 0000000000..5d8985d758 --- /dev/null +++ b/math/lapack/src/main/fortran/dorgl2.f @@ -0,0 +1,204 @@ +*> \brief \b DORGL2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORGL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. N >= M. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. M >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGELQF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL 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/math/lapack/src/main/fortran/dorglq.f b/math/lapack/src/main/fortran/dorglq.f new file mode 100644 index 0000000000..912b5de84e --- /dev/null +++ b/math/lapack/src/main/fortran/dorglq.f @@ -0,0 +1,289 @@ +*> \brief \b DORGLQ +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORGLQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. N >= M. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. M >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGELQF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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**T 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**T 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/math/lapack/src/main/fortran/dorgql.f b/math/lapack/src/main/fortran/dorgql.f new file mode 100644 index 0000000000..ea12be91b1 --- /dev/null +++ b/math/lapack/src/main/fortran/dorgql.f @@ -0,0 +1,296 @@ +*> \brief \b DORGQL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORGQL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. N >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the (n-k+i)-th column must contain the vector which +*> defines the elementary reflector H(i), for i = 1,2,...,k, as +*> returned by DGEQLF in the last k columns of its array +*> argument A. +*> On exit, the M-by-N matrix Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEQLF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dorgqr.f b/math/lapack/src/main/fortran/dorgqr.f new file mode 100644 index 0000000000..628eeacba7 --- /dev/null +++ b/math/lapack/src/main/fortran/dorgqr.f @@ -0,0 +1,290 @@ +*> \brief \b DORGQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORGQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. N >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the i-th column must contain the vector which +*> defines the elementary reflector H(i), for i = 1,2,...,k, as +*> returned by DGEQRF in the first k columns of its array +*> argument A. +*> On exit, the M-by-N matrix Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEQRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dorgr2.f b/math/lapack/src/main/fortran/dorgr2.f new file mode 100644 index 0000000000..7c5dce1d7a --- /dev/null +++ b/math/lapack/src/main/fortran/dorgr2.f @@ -0,0 +1,202 @@ +*> \brief \b DORGR2 generates all or part of the orthogonal matrix Q from an RQ factorization determined by sgerqf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORGR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. N >= M. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. M >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGERQF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, II, J, L +* .. +* .. External Subroutines .. + EXTERNAL 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/math/lapack/src/main/fortran/dorgrq.f b/math/lapack/src/main/fortran/dorgrq.f new file mode 100644 index 0000000000..b76fb37ed7 --- /dev/null +++ b/math/lapack/src/main/fortran/dorgrq.f @@ -0,0 +1,296 @@ +*> \brief \b DORGRQ +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORGRQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. N >= M. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. M >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGERQF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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**T 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**T 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/math/lapack/src/main/fortran/dorgtr.f b/math/lapack/src/main/fortran/dorgtr.f new file mode 100644 index 0000000000..72623eac06 --- /dev/null +++ b/math/lapack/src/main/fortran/dorgtr.f @@ -0,0 +1,255 @@ +*> \brief \b DORGTR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORGTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A contains elementary reflectors +*> from DSYTRD; +*> = 'L': Lower triangle of A contains elementary reflectors +*> from DSYTRD. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix Q. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-1) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DSYTRD. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dorm22.f b/math/lapack/src/main/fortran/dorm22.f new file mode 100644 index 0000000000..ac79e1e76f --- /dev/null +++ b/math/lapack/src/main/fortran/dorm22.f @@ -0,0 +1,441 @@ +*> \brief \b DORM22 multiplies a general matrix by a banded orthogonal matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORM22 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORM22( SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC, +* $ WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION Q( LDQ, * ), C( LDC, * ), WORK( * ) +* .. +* +*> \par Purpose +* ============ +*> +*> \verbatim +*> +*> +*> DORM22 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'. +*> The orthogonal matrix Q processes a 2-by-2 block structure +*> +*> [ Q11 Q12 ] +*> Q = [ ] +*> [ Q21 Q22 ], +*> +*> where Q12 is an N1-by-N1 lower triangular matrix and Q21 is an +*> N2-by-N2 upper triangular matrix. +*> \endverbatim +* +* Arguments +* ========= +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose); +*> = 'C': apply Q**T (Conjugate transpose). +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] N1 +*> \param[in] N2 +*> \verbatim +*> N1 is INTEGER +*> N2 is INTEGER +*> The dimension of Q12 and Q21, respectively. N1, N2 >= 0. +*> The following requirement must be satisfied: +*> N1 + N2 = M if SIDE = 'L' and N1 + N2 = N if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension +*> (LDQ,M) if SIDE = 'L' +*> (LDQ,N) if SIDE = 'R' +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. +*> LDQ >= max(1,M) if SIDE = 'L'; LDQ >= max(1,N) if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,N); +*> if SIDE = 'R', LWORK >= max(1,M). +*> For optimum performance LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date January 2015 +* +*> \ingroup complexOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORM22( SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO +* .. +* .. Array Arguments .. + DOUBLE PRECISION Q( LDQ, * ), C( LDC, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, LDWORK, LEN, LWKOPT, NB, NQ, NW +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DTRMM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, 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; +* NW is the minimum dimension of WORK. +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + NW = NQ + IF( N1.EQ.0 .OR. N2.EQ.0 ) NW = 1 + 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( N1.LT.0 .OR. N1+N2.NE.NQ ) THEN + INFO = -5 + ELSE IF( N2.LT.0 ) THEN + INFO = -6 + ELSE IF( LDQ.LT.MAX( 1, NQ ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = M*N + WORK( 1 ) = DBLE( LWKOPT ) + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORM22', -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 +* +* Degenerate cases (N1 = 0 or N2 = 0) are handled using DTRMM. +* + IF( N1.EQ.0 ) THEN + CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-Unit', M, N, ONE, + $ Q, LDQ, C, LDC ) + WORK( 1 ) = ONE + RETURN + ELSE IF( N2.EQ.0 ) THEN + CALL DTRMM( SIDE, 'Lower', TRANS, 'Non-Unit', M, N, ONE, + $ Q, LDQ, C, LDC ) + WORK( 1 ) = ONE + RETURN + END IF +* +* Compute the largest chunk size available from the workspace. +* + NB = MAX( 1, MIN( LWORK, LWKOPT ) / NQ ) +* + IF( LEFT ) THEN + IF( NOTRAN ) THEN + DO I = 1, N, NB + LEN = MIN( NB, N-I+1 ) + LDWORK = M +* +* Multiply bottom part of C by Q12. +* + CALL DLACPY( 'All', N1, LEN, C( N2+1, I ), LDC, WORK, + $ LDWORK ) + CALL DTRMM( 'Left', 'Lower', 'No Transpose', 'Non-Unit', + $ N1, LEN, ONE, Q( 1, N2+1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q11. +* + CALL DGEMM( 'No Transpose', 'No Transpose', N1, LEN, N2, + $ ONE, Q, LDQ, C( 1, I ), LDC, ONE, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q21. +* + CALL DLACPY( 'All', N2, LEN, C( 1, I ), LDC, + $ WORK( N1+1 ), LDWORK ) + CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'Non-Unit', + $ N2, LEN, ONE, Q( N1+1, 1 ), LDQ, + $ WORK( N1+1 ), LDWORK ) +* +* Multiply bottom part of C by Q22. +* + CALL DGEMM( 'No Transpose', 'No Transpose', N2, LEN, N1, + $ ONE, Q( N1+1, N2+1 ), LDQ, C( N2+1, I ), LDC, + $ ONE, WORK( N1+1 ), LDWORK ) +* +* Copy everything back. +* + CALL DLACPY( 'All', M, LEN, WORK, LDWORK, C( 1, I ), + $ LDC ) + END DO + ELSE + DO I = 1, N, NB + LEN = MIN( NB, N-I+1 ) + LDWORK = M +* +* Multiply bottom part of C by Q21**T. +* + CALL DLACPY( 'All', N2, LEN, C( N1+1, I ), LDC, WORK, + $ LDWORK ) + CALL DTRMM( 'Left', 'Upper', 'Transpose', 'Non-Unit', + $ N2, LEN, ONE, Q( N1+1, 1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q11**T. +* + CALL DGEMM( 'Transpose', 'No Transpose', N2, LEN, N1, + $ ONE, Q, LDQ, C( 1, I ), LDC, ONE, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q12**T. +* + CALL DLACPY( 'All', N1, LEN, C( 1, I ), LDC, + $ WORK( N2+1 ), LDWORK ) + CALL DTRMM( 'Left', 'Lower', 'Transpose', 'Non-Unit', + $ N1, LEN, ONE, Q( 1, N2+1 ), LDQ, + $ WORK( N2+1 ), LDWORK ) +* +* Multiply bottom part of C by Q22**T. +* + CALL DGEMM( 'Transpose', 'No Transpose', N1, LEN, N2, + $ ONE, Q( N1+1, N2+1 ), LDQ, C( N1+1, I ), LDC, + $ ONE, WORK( N2+1 ), LDWORK ) +* +* Copy everything back. +* + CALL DLACPY( 'All', M, LEN, WORK, LDWORK, C( 1, I ), + $ LDC ) + END DO + END IF + ELSE + IF( NOTRAN ) THEN + DO I = 1, M, NB + LEN = MIN( NB, M-I+1 ) + LDWORK = LEN +* +* Multiply right part of C by Q21. +* + CALL DLACPY( 'All', LEN, N2, C( I, N1+1 ), LDC, WORK, + $ LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', + $ LEN, N2, ONE, Q( N1+1, 1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q11. +* + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, N2, N1, + $ ONE, C( I, 1 ), LDC, Q, LDQ, ONE, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q12. +* + CALL DLACPY( 'All', LEN, N1, C( I, 1 ), LDC, + $ WORK( 1 + N2*LDWORK ), LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'No Transpose', 'Non-Unit', + $ LEN, N1, ONE, Q( 1, N2+1 ), LDQ, + $ WORK( 1 + N2*LDWORK ), LDWORK ) +* +* Multiply right part of C by Q22. +* + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, N1, N2, + $ ONE, C( I, N1+1 ), LDC, Q( N1+1, N2+1 ), LDQ, + $ ONE, WORK( 1 + N2*LDWORK ), LDWORK ) +* +* Copy everything back. +* + CALL DLACPY( 'All', LEN, N, WORK, LDWORK, C( I, 1 ), + $ LDC ) + END DO + ELSE + DO I = 1, M, NB + LEN = MIN( NB, M-I+1 ) + LDWORK = LEN +* +* Multiply right part of C by Q12**T. +* + CALL DLACPY( 'All', LEN, N1, C( I, N2+1 ), LDC, WORK, + $ LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Non-Unit', + $ LEN, N1, ONE, Q( 1, N2+1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q11**T. +* + CALL DGEMM( 'No Transpose', 'Transpose', LEN, N1, N2, + $ ONE, C( I, 1 ), LDC, Q, LDQ, ONE, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q21**T. +* + CALL DLACPY( 'All', LEN, N2, C( I, 1 ), LDC, + $ WORK( 1 + N1*LDWORK ), LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', + $ LEN, N2, ONE, Q( N1+1, 1 ), LDQ, + $ WORK( 1 + N1*LDWORK ), LDWORK ) +* +* Multiply right part of C by Q22**T. +* + CALL DGEMM( 'No Transpose', 'Transpose', LEN, N2, N1, + $ ONE, C( I, N2+1 ), LDC, Q( N1+1, N2+1 ), LDQ, + $ ONE, WORK( 1 + N1*LDWORK ), LDWORK ) +* +* Copy everything back. +* + CALL DLACPY( 'All', LEN, N, WORK, LDWORK, C( I, 1 ), + $ LDC ) + END DO + END IF + END IF +* + WORK( 1 ) = DBLE( LWKOPT ) + RETURN +* +* End of DORM22 +* + END diff --git a/math/lapack/src/main/fortran/dorm2l.f b/math/lapack/src/main/fortran/dorm2l.f new file mode 100644 index 0000000000..1014cb2378 --- /dev/null +++ b/math/lapack/src/main/fortran/dorm2l.f @@ -0,0 +1,278 @@ +*> \brief \b DORM2L multiplies a general matrix by the orthogonal matrix from a QL factorization determined by sgeqlf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORM2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORM2L overwrites the general real m by n matrix C with +*> +*> Q * C if SIDE = 'L' and TRANS = 'N', or +*> +*> Q**T * C if SIDE = 'L' and TRANS = 'T', or +*> +*> C * Q if SIDE = 'R' and TRANS = 'N', or +*> +*> C * Q**T if SIDE = 'R' and TRANS = 'T', +*> +*> where Q is a real orthogonal matrix defined as the product of k +*> elementary reflectors +*> +*> Q = H(k) . . . H(2) H(1) +*> +*> as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n +*> if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left +*> = 'R': apply Q or Q**T from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose) +*> = 'T': apply Q**T (Transpose) +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGEQLF in the last k columns of its array argument A. +*> A is modified by the routine but restored on exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEQLF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L', +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, MI, NI, NQ + 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/math/lapack/src/main/fortran/dorm2r.f b/math/lapack/src/main/fortran/dorm2r.f new file mode 100644 index 0000000000..632b70e740 --- /dev/null +++ b/math/lapack/src/main/fortran/dorm2r.f @@ -0,0 +1,282 @@ +*> \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORM2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORM2R overwrites the general real m by n matrix C with +*> +*> Q * C if SIDE = 'L' and TRANS = 'N', or +*> +*> Q**T* C if SIDE = 'L' and TRANS = 'T', or +*> +*> C * Q if SIDE = 'R' and TRANS = 'N', or +*> +*> C * Q**T if SIDE = 'R' and TRANS = 'T', +*> +*> where Q is a real orthogonal matrix defined as the product of k +*> elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k) +*> +*> as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n +*> if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left +*> = 'R': apply Q or Q**T from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose) +*> = 'T': apply Q**T (Transpose) +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGEQRF in the first k columns of its array argument A. +*> A is modified by the routine but restored on exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEQRF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L', +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + 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/math/lapack/src/main/fortran/dormbr.f b/math/lapack/src/main/fortran/dormbr.f new file mode 100644 index 0000000000..f035d0ae66 --- /dev/null +++ b/math/lapack/src/main/fortran/dormbr.f @@ -0,0 +1,372 @@ +*> \brief \b DORMBR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORMBR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, +* LDC, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS, VECT +* INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] VECT +*> \verbatim +*> VECT is CHARACTER*1 +*> = 'Q': apply Q or Q**T; +*> = 'P': apply P or P**T. +*> \endverbatim +*> +*> \param[in] SIDE +*> \verbatim +*> SIDE is 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. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q or P; +*> = 'T': Transpose, apply Q**T or P**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is 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. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If VECT = 'Q', LDA >= max(1,nq); +*> if VECT = 'P', LDA >= max(1,min(nq,K)). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is 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. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q +*> or P*C or P**T*C or C*P or C*P**T. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, + $ LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS, VECT + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dormhr.f b/math/lapack/src/main/fortran/dormhr.f new file mode 100644 index 0000000000..d1e214e0f2 --- /dev/null +++ b/math/lapack/src/main/fortran/dormhr.f @@ -0,0 +1,294 @@ +*> \brief \b DORMHR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORMHR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, +* LDC, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is 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. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is 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. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, + $ LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dorml2.f b/math/lapack/src/main/fortran/dorml2.f new file mode 100644 index 0000000000..2c55c7f1fd --- /dev/null +++ b/math/lapack/src/main/fortran/dorml2.f @@ -0,0 +1,282 @@ +*> \brief \b DORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined by sgelqf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORML2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORML2 overwrites the general real m by n matrix C with +*> +*> Q * C if SIDE = 'L' and TRANS = 'N', or +*> +*> Q**T* C if SIDE = 'L' and TRANS = 'T', or +*> +*> C * Q if SIDE = 'R' and TRANS = 'N', or +*> +*> C * Q**T if SIDE = 'R' and TRANS = 'T', +*> +*> where Q is a real orthogonal matrix defined as the product of k +*> elementary reflectors +*> +*> Q = H(k) . . . H(2) H(1) +*> +*> as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n +*> if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left +*> = 'R': apply Q or Q**T from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose) +*> = 'T': apply Q**T (Transpose) +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension +*> (LDA,M) if SIDE = 'L', +*> (LDA,N) if SIDE = 'R' +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGELQF in the first k rows of its array argument A. +*> A is modified by the routine but restored on exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,K). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGELQF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L', +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + 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/math/lapack/src/main/fortran/dormlq.f b/math/lapack/src/main/fortran/dormlq.f new file mode 100644 index 0000000000..bb5469d273 --- /dev/null +++ b/math/lapack/src/main/fortran/dormlq.f @@ -0,0 +1,347 @@ +*> \brief \b DORMLQ +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORMLQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension +*> (LDA,M) if SIDE = 'L', +*> (LDA,N) if SIDE = 'R' +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGELQF in the first k rows of its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,K). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGELQF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,N); +*> if SIDE = 'R', LWORK >= max(1,M). +*> 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT, TSIZE + PARAMETER ( NBMAX = 64, LDT = NBMAX+1, + $ TSIZE = LDT*NBMAX ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + CHARACTER TRANST + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. 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 +* +* Compute the workspace requirements +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + TSIZE + 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 + IF( LWORK.LT.NW*NB+TSIZE ) THEN + NB = (LWORK-TSIZE) / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + 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 +* + IWT = 1 + NW*NB + 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 ), WORK( IWT ), LDT ) + IF( LEFT ) THEN +* +* H or H**T is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H or H**T is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H or H**T +* + CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, + $ A( I, I ), LDA, WORK( IWT ), LDT, + $ C( IC, JC ), LDC, WORK, LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMLQ +* + END diff --git a/math/lapack/src/main/fortran/dormql.f b/math/lapack/src/main/fortran/dormql.f new file mode 100644 index 0000000000..7d2b5d6c32 --- /dev/null +++ b/math/lapack/src/main/fortran/dormql.f @@ -0,0 +1,339 @@ +*> \brief \b DORMQL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORMQL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGEQLF in the last k columns of its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEQLF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,N); +*> if SIDE = 'R', LWORK >= max(1,M). +*> 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT, TSIZE + PARAMETER ( NBMAX = 64, LDT = NBMAX+1, + $ TSIZE = LDT*NBMAX ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, I1, I2, I3, IB, IINFO, IWT, LDWORK, LWKOPT, + $ MI, NB, NBMIN, NI, NQ, NW +* .. +* .. 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 + ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Compute the workspace requirements +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + NB = MIN( NBMAX, ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N, + $ K, -1 ) ) + LWKOPT = NW*NB + TSIZE + END IF + WORK( 1 ) = LWKOPT + 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 + IF( LWORK.LT.NW*NB+TSIZE ) THEN + NB = (LWORK-TSIZE) / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMQL', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + 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 +* + IWT = 1 + NW*NB + 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 ), WORK( IWT ), LDT ) + IF( LEFT ) THEN +* +* H or H**T is applied to C(1:m-k+i+ib-1,1:n) +* + MI = M - K + I + IB - 1 + ELSE +* +* H or H**T is applied to C(1:m,1:n-k+i+ib-1) +* + NI = N - K + I + IB - 1 + END IF +* +* Apply H or H**T +* + CALL DLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI, + $ IB, A( 1, I ), LDA, WORK( IWT ), LDT, C, LDC, + $ WORK, LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMQL +* + END diff --git a/math/lapack/src/main/fortran/dormqr.f b/math/lapack/src/main/fortran/dormqr.f new file mode 100644 index 0000000000..7f2ebb9ace --- /dev/null +++ b/math/lapack/src/main/fortran/dormqr.f @@ -0,0 +1,340 @@ +*> \brief \b DORMQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORMQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGEQRF in the first k columns of its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEQRF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,N); +*> if SIDE = 'R', LWORK >= max(1,M). +*> 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT, TSIZE + PARAMETER ( NBMAX = 64, LDT = NBMAX+1, + $ TSIZE = LDT*NBMAX ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. 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 +* +* Compute the workspace requirements +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + TSIZE + 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 + IF( LWORK.LT.NW*NB+TSIZE ) THEN + NB = (LWORK-TSIZE) / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + 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 +* + IWT = 1 + NW*NB + 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 ), WORK( IWT ), LDT ) + IF( LEFT ) THEN +* +* H or H**T is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H or H**T is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H or H**T +* + CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, + $ IB, A( I, I ), LDA, WORK( IWT ), LDT, + $ C( IC, JC ), LDC, WORK, LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMQR +* + END diff --git a/math/lapack/src/main/fortran/dormr2.f b/math/lapack/src/main/fortran/dormr2.f new file mode 100644 index 0000000000..129ee1b494 --- /dev/null +++ b/math/lapack/src/main/fortran/dormr2.f @@ -0,0 +1,278 @@ +*> \brief \b DORMR2 multiplies a general matrix by the orthogonal matrix from a RQ factorization determined by sgerqf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORMR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORMR2 overwrites the general real m by n matrix C with +*> +*> Q * C if SIDE = 'L' and TRANS = 'N', or +*> +*> Q**T* C if SIDE = 'L' and TRANS = 'T', or +*> +*> C * Q if SIDE = 'R' and TRANS = 'N', or +*> +*> C * Q**T if SIDE = 'R' and TRANS = 'T', +*> +*> where Q is a real orthogonal matrix defined as the product of k +*> elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k) +*> +*> as returned by DGERQF. Q is of order m if SIDE = 'L' and of order n +*> if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left +*> = 'R': apply Q or Q**T from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose) +*> = 'T': apply Q' (Transpose) +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension +*> (LDA,M) if SIDE = 'L', +*> (LDA,N) if SIDE = 'R' +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGERQF in the last k rows of its array argument A. +*> A is modified by the routine but restored on exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,K). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGERQF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L', +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, MI, NI, NQ + 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/math/lapack/src/main/fortran/dormr3.f b/math/lapack/src/main/fortran/dormr3.f new file mode 100644 index 0000000000..5f20db724c --- /dev/null +++ b/math/lapack/src/main/fortran/dormr3.f @@ -0,0 +1,299 @@ +*> \brief \b DORMR3 multiplies a general matrix by the orthogonal matrix from a RZ factorization determined by stzrzf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORMR3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, L, LDA, LDC, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORMR3 overwrites the general real m by n matrix C with +*> +*> Q * C if SIDE = 'L' and TRANS = 'N', or +*> +*> Q**T* C if SIDE = 'L' and TRANS = 'C', or +*> +*> C * Q if SIDE = 'R' and TRANS = 'N', or +*> +*> C * Q**T if SIDE = 'R' and TRANS = 'C', +*> +*> 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'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left +*> = 'R': apply Q or Q**T from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose) +*> = 'T': apply Q**T (Transpose) +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is 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. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension +*> (LDA,M) if SIDE = 'L', +*> (LDA,N) if SIDE = 'R' +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DTZRZF in the last k rows of its array argument A. +*> A is modified by the routine but restored on exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,K). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DTZRZF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m-by-n matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L', +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, L, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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)**T is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) or H(i)**T is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) or H(i)**T +* + 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/math/lapack/src/main/fortran/dormrq.f b/math/lapack/src/main/fortran/dormrq.f new file mode 100644 index 0000000000..421bd104bf --- /dev/null +++ b/math/lapack/src/main/fortran/dormrq.f @@ -0,0 +1,346 @@ +*> \brief \b DORMRQ +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORMRQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension +*> (LDA,M) if SIDE = 'L', +*> (LDA,N) if SIDE = 'R' +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGERQF in the last k rows of its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,K). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGERQF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,N); +*> if SIDE = 'R', LWORK >= max(1,M). +*> 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT, TSIZE + PARAMETER ( NBMAX = 64, LDT = NBMAX+1, + $ TSIZE = LDT*NBMAX ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + CHARACTER TRANST + INTEGER I, I1, I2, I3, IB, IINFO, IWT, LDWORK, LWKOPT, + $ MI, NB, NBMIN, NI, NQ, NW +* .. +* .. 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 + ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Compute the workspace requirements +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + NB = MIN( NBMAX, ILAENV( 1, 'DORMRQ', SIDE // TRANS, M, N, + $ K, -1 ) ) + LWKOPT = NW*NB + TSIZE + END IF + WORK( 1 ) = LWKOPT + 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 + IF( LWORK.LT.NW*NB+TSIZE ) THEN + NB = (LWORK-TSIZE) / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMRQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + 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 +* + IWT = 1 + NW*NB + 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 ), WORK( IWT ), LDT ) + IF( LEFT ) THEN +* +* H or H**T is applied to C(1:m-k+i+ib-1,1:n) +* + MI = M - K + I + IB - 1 + ELSE +* +* H or H**T is applied to C(1:m,1:n-k+i+ib-1) +* + NI = N - K + I + IB - 1 + END IF +* +* Apply H or H**T +* + CALL DLARFB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI, + $ IB, A( I, 1 ), LDA, WORK( IWT ), LDT, C, LDC, + $ WORK, LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMRQ +* + END diff --git a/math/lapack/src/main/fortran/dormrz.f b/math/lapack/src/main/fortran/dormrz.f new file mode 100644 index 0000000000..8e1bd56ccc --- /dev/null +++ b/math/lapack/src/main/fortran/dormrz.f @@ -0,0 +1,380 @@ +*> \brief \b DORMRZ +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORMRZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, L, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is 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. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension +*> (LDA,M) if SIDE = 'L', +*> (LDA,N) if SIDE = 'R' +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DTZRZF in the last k rows of its array argument A. +*> A is modified by the routine but restored on exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,K). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DTZRZF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,N); +*> if SIDE = 'R', LWORK >= max(1,M). +*> 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, L, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT, TSIZE + PARAMETER ( NBMAX = 64, LDT = NBMAX+1, + $ TSIZE = LDT*NBMAX ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + CHARACTER TRANST + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JA, JC, + $ LDWORK, LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. 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 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Compute the workspace requirements +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + NB = MIN( NBMAX, ILAENV( 1, 'DORMRQ', SIDE // TRANS, M, N, + $ K, -1 ) ) + LWKOPT = NW*NB + TSIZE + END IF + WORK( 1 ) = LWKOPT + 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 + IF( LWORK.LT.NW*NB+TSIZE ) THEN + NB = (LWORK-TSIZE) / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMRQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + 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 +* + IWT = 1 + NW*NB + 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 ), WORK( IWT ), LDT ) +* + IF( LEFT ) THEN +* +* H or H**T is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H or H**T is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H or H**T +* + CALL DLARZB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI, + $ IB, L, A( I, JA ), LDA, WORK( IWT ), LDT, + $ C( IC, JC ), LDC, WORK, LDWORK ) + 10 CONTINUE +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DORMRZ +* + END diff --git a/math/lapack/src/main/fortran/dormtr.f b/math/lapack/src/main/fortran/dormtr.f new file mode 100644 index 0000000000..d2443c1dac --- /dev/null +++ b/math/lapack/src/main/fortran/dormtr.f @@ -0,0 +1,310 @@ +*> \brief \b DORMTR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORMTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS, UPLO +* INTEGER INFO, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORMTR overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> +*> where Q is a real orthogonal matrix of order nq, with nq = m if +*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of +*> nq-1 elementary reflectors, as returned by DSYTRD: +*> +*> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); +*> +*> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A contains elementary reflectors +*> from DSYTRD; +*> = 'L': Lower triangle of A contains elementary reflectors +*> from DSYTRD. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension +*> (LDA,M) if SIDE = 'L' +*> (LDA,N) if SIDE = 'R' +*> The vectors which define the elementary reflectors, as +*> returned by DSYTRD. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension +*> (M-1) if SIDE = 'L' +*> (N-1) if SIDE = 'R' +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DSYTRD. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS, UPLO + INTEGER INFO, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, UPPER + INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DORMQL, DORMQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + UPPER = LSAME( UPLO, 'U' ) + 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.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .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( 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 + IF( UPPER ) THEN + IF( LEFT ) THEN + NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M-1, N, M-1, + $ -1 ) + ELSE + NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N-1, N-1, + $ -1 ) + END IF + ELSE + 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 + END IF + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMTR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( LEFT ) THEN + MI = M - 1 + NI = N + ELSE + MI = M + NI = N - 1 + END IF +* + IF( UPPER ) THEN +* +* Q was determined by a call to DSYTRD with UPLO = 'U' +* + CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C, + $ LDC, WORK, LWORK, IINFO ) + ELSE +* +* Q was determined by a call to DSYTRD with UPLO = 'L' +* + IF( LEFT ) THEN + I1 = 2 + I2 = 1 + ELSE + 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 + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMTR +* + END diff --git a/math/lapack/src/main/fortran/dpbcon.f b/math/lapack/src/main/fortran/dpbcon.f new file mode 100644 index 0000000000..41d43dc492 --- /dev/null +++ b/math/lapack/src/main/fortran/dpbcon.f @@ -0,0 +1,271 @@ +*> \brief \b DPBCON +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPBCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, +* IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KD, LDAB, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPBCON estimates the reciprocal of the condition number (in the +*> 1-norm) of a real symmetric positive definite band matrix using the +*> Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangular factor stored in AB; +*> = 'L': Lower triangular factor stored in AB. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> The triangular factor U or L from the Cholesky factorization +*> A = U**T*U or A = L*L**T of the band matrix A, stored in the +*> first KD+1 rows of the array. The j-th column of U or L is +*> stored in the j-th column of the array AB as follows: +*> if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is DOUBLE PRECISION +*> The 1-norm (or infinity-norm) of the symmetric band matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, + $ IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KD, LDAB, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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, DLATBS, DRSCL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. 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( KD.LT.0 ) THEN + INFO = -3 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -5 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPBCON', -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 the inverse. +* + 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**T). +* + CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, + $ KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ), + $ INFO ) + NORMIN = 'Y' +* +* Multiply by inv(U). +* + CALL DLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, + $ KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ), + $ INFO ) + ELSE +* +* Multiply by inv(L). +* + CALL DLATBS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N, + $ KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ), + $ INFO ) + NORMIN = 'Y' +* +* Multiply by inv(L**T). +* + CALL DLATBS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N, + $ KD, AB, LDAB, 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 DPBCON +* + END diff --git a/math/lapack/src/main/fortran/dpbequ.f b/math/lapack/src/main/fortran/dpbequ.f new file mode 100644 index 0000000000..ec5d4eb766 --- /dev/null +++ b/math/lapack/src/main/fortran/dpbequ.f @@ -0,0 +1,242 @@ +*> \brief \b DPBEQU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPBEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KD, LDAB, N +* DOUBLE PRECISION AMAX, SCOND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), S( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPBEQU computes row and column scalings intended to equilibrate a +*> symmetric positive definite band matrix A and reduce its condition +*> number (with respect to the two-norm). S contains the scale factors, +*> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with +*> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This +*> choice of S puts the condition number of B within a factor N of the +*> smallest possible condition number over all possible diagonal +*> scalings. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangular of A is stored; +*> = 'L': Lower triangular of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> The upper or lower triangle of the symmetric band matrix A, +*> stored in the first KD+1 rows of the array. The j-th column +*> of A is stored in the j-th column of the array AB as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array A. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, S contains the scale factors for A. +*> \endverbatim +*> +*> \param[out] SCOND +*> \verbatim +*> SCOND is DOUBLE PRECISION +*> If INFO = 0, S contains the ratio of the smallest S(i) to +*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too +*> large nor too small, it is not worth scaling by S. +*> \endverbatim +*> +*> \param[out] AMAX +*> \verbatim +*> AMAX is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the i-th diagonal element is nonpositive. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KD, LDAB, N + DOUBLE PRECISION AMAX, SCOND +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), S( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, J + DOUBLE PRECISION SMIN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, 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( KD.LT.0 ) THEN + INFO = -3 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPBEQU', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + SCOND = ONE + AMAX = ZERO + RETURN + END IF +* + IF( UPPER ) THEN + J = KD + 1 + ELSE + J = 1 + END IF +* +* Initialize SMIN and AMAX. +* + S( 1 ) = AB( J, 1 ) + SMIN = S( 1 ) + AMAX = S( 1 ) +* +* Find the minimum and maximum diagonal elements. +* + DO 10 I = 2, N + S( I ) = AB( J, I ) + SMIN = MIN( SMIN, S( I ) ) + AMAX = MAX( AMAX, S( I ) ) + 10 CONTINUE +* + IF( SMIN.LE.ZERO ) THEN +* +* Find the first non-positive diagonal element and return. +* + DO 20 I = 1, N + IF( S( I ).LE.ZERO ) THEN + INFO = I + RETURN + END IF + 20 CONTINUE + ELSE +* +* Set the scale factors to the reciprocals +* of the diagonal elements. +* + DO 30 I = 1, N + S( I ) = ONE / SQRT( S( I ) ) + 30 CONTINUE +* +* Compute SCOND = min(S(I)) / max(S(I)) +* + SCOND = SQRT( SMIN ) / SQRT( AMAX ) + END IF + RETURN +* +* End of DPBEQU +* + END diff --git a/math/lapack/src/main/fortran/dpbrfs.f b/math/lapack/src/main/fortran/dpbrfs.f new file mode 100644 index 0000000000..6bc522fa8d --- /dev/null +++ b/math/lapack/src/main/fortran/dpbrfs.f @@ -0,0 +1,443 @@ +*> \brief \b DPBRFS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPBRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, +* LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), +* $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPBRFS improves the computed solution to a system of linear +*> equations when the coefficient matrix is symmetric positive definite +*> and banded, and provides error bounds and backward error estimates +*> for the solution. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> The upper or lower triangle of the symmetric band matrix A, +*> stored in the first KD+1 rows of the array. The j-th column +*> of A is stored in the j-th column of the array AB as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[in] AFB +*> \verbatim +*> AFB is DOUBLE PRECISION array, dimension (LDAFB,N) +*> The triangular factor U or L from the Cholesky factorization +*> A = U**T*U or A = L*L**T of the band matrix A as computed by +*> DPBTRF, in the same storage format as A (see AB). +*> \endverbatim +*> +*> \param[in] LDAFB +*> \verbatim +*> LDAFB is INTEGER +*> The leading dimension of the array AFB. LDAFB >= KD+1. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> On entry, the solution matrix X, as computed by DPBTRS. +*> On exit, the improved solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> ITMAX is the maximum number of steps of iterative refinement. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, + $ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. 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 UPPER + INTEGER COUNT, I, J, K, KASE, L, NZ + DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLACN2, DPBTRS, DSBMV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. 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( KD.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -6 + ELSE IF( LDAFB.LT.KD+1 ) THEN + INFO = -8 + 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( 'DPBRFS', -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 +* +* NZ = maximum number of nonzero elements in each row of A, plus 1 +* + NZ = MIN( N+1, 2*KD+2 ) + 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 - A * X +* + CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) + CALL DSBMV( UPLO, N, KD, -ONE, AB, LDAB, X( 1, J ), 1, ONE, + $ WORK( N+1 ), 1 ) +* +* Compute componentwise relative backward error from formula +* +* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) +* +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. If the i-th component of the denominator is less +* than SAFE2, then SAFE1 is added to the i-th components of the +* numerator and denominator before dividing. +* + DO 30 I = 1, N + WORK( I ) = ABS( B( I, J ) ) + 30 CONTINUE +* +* Compute abs(A)*abs(X) + abs(B). +* + IF( UPPER ) THEN + DO 50 K = 1, N + S = ZERO + XK = ABS( X( K, J ) ) + L = KD + 1 - K + DO 40 I = MAX( 1, K-KD ), K - 1 + WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK + S = S + ABS( AB( L+I, K ) )*ABS( X( I, J ) ) + 40 CONTINUE + WORK( K ) = WORK( K ) + ABS( AB( KD+1, K ) )*XK + S + 50 CONTINUE + ELSE + DO 70 K = 1, N + S = ZERO + XK = ABS( X( K, J ) ) + WORK( K ) = WORK( K ) + ABS( AB( 1, K ) )*XK + L = 1 - K + DO 60 I = K + 1, MIN( N, K+KD ) + WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK + S = S + ABS( AB( L+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 DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, 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(A))* +* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) +* +* where +* norm(Z) is the magnitude of the largest component of Z +* inv(A) is the inverse of A +* abs(Z) is the componentwise absolute value of the matrix or +* vector Z +* NZ is the maximum number of nonzeros in any row of A, plus 1 +* EPS is machine epsilon +* +* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) +* is incremented by SAFE1 if the i-th component of +* abs(A)*abs(X) + abs(B) is less than SAFE2. +* +* Use DLACN2 to estimate the infinity-norm of the matrix +* inv(A) * diag(W), +* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) +* + 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(A**T). +* + CALL DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N, + $ INFO ) + DO 110 I = 1, N + WORK( N+I ) = WORK( N+I )*WORK( I ) + 110 CONTINUE + ELSE IF( KASE.EQ.2 ) THEN +* +* Multiply by inv(A)*diag(W). +* + DO 120 I = 1, N + WORK( N+I ) = WORK( N+I )*WORK( I ) + 120 CONTINUE + CALL DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, 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 DPBRFS +* + END diff --git a/math/lapack/src/main/fortran/dpbstf.f b/math/lapack/src/main/fortran/dpbstf.f new file mode 100644 index 0000000000..c104ddbeab --- /dev/null +++ b/math/lapack/src/main/fortran/dpbstf.f @@ -0,0 +1,319 @@ +*> \brief \b DPBSTF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPBSTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KD, LDAB, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPBSTF computes a split Cholesky factorization of a real +*> symmetric positive definite band matrix A. +*> +*> This routine is designed to be used in conjunction with DSBGST. +*> +*> The factorization has the form A = S**T*S where S is a band matrix +*> of the same bandwidth as A and the following structure: +*> +*> S = ( U ) +*> ( M L ) +*> +*> where U is upper triangular of order m = (n+kd)/2, and L is lower +*> triangular of order n-m. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first kd+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, if INFO = 0, the factor S from the split Cholesky +*> factorization A = S**T*S. See Further Details. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the factorization could not be completed, +*> because the updated element a(i,i) was negative; the +*> matrix A is not positive definite. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The band storage scheme is illustrated by the following example, when +*> N = 7, KD = 2: +*> +*> S = ( s11 s12 s13 ) +*> ( s22 s23 s24 ) +*> ( s33 s34 ) +*> ( s44 ) +*> ( s53 s54 s55 ) +*> ( s64 s65 s66 ) +*> ( s75 s76 s77 ) +*> +*> If UPLO = 'U', the array AB holds: +*> +*> on entry: on exit: +*> +*> * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75 +*> * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76 +*> a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 +*> +*> If UPLO = 'L', the array AB holds: +*> +*> on entry: on exit: +*> +*> a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 +*> a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 * +*> a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * * +*> +*> Array elements marked * are not used by the routine. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KD, LDAB, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, KLD, KM, M + DOUBLE PRECISION AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSYR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, 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( KD.LT.0 ) THEN + INFO = -3 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPBSTF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + KLD = MAX( 1, LDAB-1 ) +* +* Set the splitting point m. +* + M = ( N+KD ) / 2 +* + IF( UPPER ) THEN +* +* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). +* + DO 10 J = N, M + 1, -1 +* +* Compute s(j,j) and test for non-positive-definiteness. +* + AJJ = AB( KD+1, J ) + IF( AJJ.LE.ZERO ) + $ GO TO 50 + AJJ = SQRT( AJJ ) + AB( KD+1, J ) = AJJ + KM = MIN( J-1, KD ) +* +* Compute elements j-km:j-1 of the j-th column and update the +* the leading submatrix within the band. +* + CALL DSCAL( KM, ONE / AJJ, AB( KD+1-KM, J ), 1 ) + CALL DSYR( 'Upper', KM, -ONE, AB( KD+1-KM, J ), 1, + $ AB( KD+1, J-KM ), KLD ) + 10 CONTINUE +* +* Factorize the updated submatrix A(1:m,1:m) as U**T*U. +* + DO 20 J = 1, M +* +* Compute s(j,j) and test for non-positive-definiteness. +* + AJJ = AB( KD+1, J ) + IF( AJJ.LE.ZERO ) + $ GO TO 50 + AJJ = SQRT( AJJ ) + AB( KD+1, J ) = AJJ + KM = MIN( KD, M-J ) +* +* Compute elements j+1:j+km of the j-th row and update the +* trailing submatrix within the band. +* + IF( KM.GT.0 ) THEN + CALL DSCAL( KM, ONE / AJJ, AB( KD, J+1 ), KLD ) + CALL DSYR( 'Upper', KM, -ONE, AB( KD, J+1 ), KLD, + $ AB( KD+1, J+1 ), KLD ) + END IF + 20 CONTINUE + ELSE +* +* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). +* + DO 30 J = N, M + 1, -1 +* +* Compute s(j,j) and test for non-positive-definiteness. +* + AJJ = AB( 1, J ) + IF( AJJ.LE.ZERO ) + $ GO TO 50 + AJJ = SQRT( AJJ ) + AB( 1, J ) = AJJ + KM = MIN( J-1, KD ) +* +* Compute elements j-km:j-1 of the j-th row and update the +* trailing submatrix within the band. +* + CALL DSCAL( KM, ONE / AJJ, AB( KM+1, J-KM ), KLD ) + CALL DSYR( 'Lower', KM, -ONE, AB( KM+1, J-KM ), KLD, + $ AB( 1, J-KM ), KLD ) + 30 CONTINUE +* +* Factorize the updated submatrix A(1:m,1:m) as U**T*U. +* + DO 40 J = 1, M +* +* Compute s(j,j) and test for non-positive-definiteness. +* + AJJ = AB( 1, J ) + IF( AJJ.LE.ZERO ) + $ GO TO 50 + AJJ = SQRT( AJJ ) + AB( 1, J ) = AJJ + KM = MIN( KD, M-J ) +* +* Compute elements j+1:j+km of the j-th column and update the +* trailing submatrix within the band. +* + IF( KM.GT.0 ) THEN + CALL DSCAL( KM, ONE / AJJ, AB( 2, J ), 1 ) + CALL DSYR( 'Lower', KM, -ONE, AB( 2, J ), 1, + $ AB( 1, J+1 ), KLD ) + END IF + 40 CONTINUE + END IF + RETURN +* + 50 CONTINUE + INFO = J + RETURN +* +* End of DPBSTF +* + END diff --git a/math/lapack/src/main/fortran/dpbsv.f b/math/lapack/src/main/fortran/dpbsv.f new file mode 100644 index 0000000000..535a2d40ec --- /dev/null +++ b/math/lapack/src/main/fortran/dpbsv.f @@ -0,0 +1,229 @@ +*> \brief DPBSV computes the solution to system of linear equations A * X = B for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPBSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KD, LDAB, LDB, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPBSV computes the solution to a real system of linear equations +*> A * X = B, +*> where A is an N-by-N symmetric positive definite band matrix and X +*> and B are N-by-NRHS matrices. +*> +*> The Cholesky decomposition is used to factor A as +*> A = U**T * U, if UPLO = 'U', or +*> A = L * L**T, if UPLO = 'L', +*> where U is an upper triangular band matrix, and L is a lower +*> triangular band matrix, with the same number of superdiagonals or +*> subdiagonals as A. The factored form of A is then used to solve the +*> system of equations A * X = B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). +*> See below for further details. +*> +*> On exit, if INFO = 0, the triangular factor U or L from the +*> Cholesky factorization A = U**T*U or A = L*L**T of the band +*> matrix A, in the same storage format as A. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the leading minor of order i of A is not +*> positive definite, so the factorization could not be +*> completed, and the solution has not been computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERsolve +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The band storage scheme is illustrated by the following example, when +*> N = 6, KD = 2, and UPLO = 'U': +*> +*> On entry: On exit: +*> +*> * * a13 a24 a35 a46 * * u13 u24 u35 u46 +*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 +*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 +*> +*> Similarly, if UPLO = 'L' the format of A is as follows: +*> +*> On entry: On exit: +*> +*> a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 +*> a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * +*> a31 a42 a53 a64 * * l31 l42 l53 l64 * * +*> +*> Array elements marked * are not used by the routine. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KD, LDAB, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DPBTRF, DPBTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KD.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPBSV ', -INFO ) + RETURN + END IF +* +* Compute the Cholesky factorization A = U**T*U or A = L*L**T. +* + CALL DPBTRF( UPLO, N, KD, AB, LDAB, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) +* + END IF + RETURN +* +* End of DPBSV +* + END diff --git a/math/lapack/src/main/fortran/dpbsvx.f b/math/lapack/src/main/fortran/dpbsvx.f new file mode 100644 index 0000000000..b194d26a45 --- /dev/null +++ b/math/lapack/src/main/fortran/dpbsvx.f @@ -0,0 +1,545 @@ +*> \brief DPBSVX computes the solution to system of linear equations A * X = B for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPBSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, +* EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER EQUED, FACT, UPLO +* INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), +* $ BERR( * ), FERR( * ), S( * ), WORK( * ), +* $ X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to +*> compute the solution to a real system of linear equations +*> A * X = B, +*> where A is an N-by-N symmetric positive definite band matrix and X +*> and B are N-by-NRHS matrices. +*> +*> Error bounds on the solution and a condition estimate are also +*> provided. +*> \endverbatim +* +*> \par Description: +* ================= +*> +*> \verbatim +*> +*> The following steps are performed: +*> +*> 1. If FACT = 'E', real scaling factors are computed to equilibrate +*> the system: +*> diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B +*> Whether or not the system will be equilibrated depends on the +*> scaling of the matrix A, but if equilibration is used, A is +*> overwritten by diag(S)*A*diag(S) and B by diag(S)*B. +*> +*> 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to +*> factor the matrix A (after equilibration if FACT = 'E') as +*> A = U**T * U, if UPLO = 'U', or +*> A = L * L**T, if UPLO = 'L', +*> where U is an upper triangular band matrix, and L is a lower +*> triangular band matrix. +*> +*> 3. If the leading i-by-i principal minor is not positive definite, +*> then the routine returns with INFO = i. Otherwise, the factored +*> form of A is used to estimate the condition number of the matrix +*> A. If the reciprocal of the condition number is less than machine +*> precision, INFO = N+1 is returned as a warning, but the routine +*> still goes on to solve for X and compute error bounds as +*> described below. +*> +*> 4. The system of equations is solved for X using the factored form +*> of A. +*> +*> 5. Iterative refinement is applied to improve the computed solution +*> matrix and calculate error bounds and backward error estimates +*> for it. +*> +*> 6. If equilibration was used, the matrix X is premultiplied by +*> diag(S) so that it solves the original system before +*> equilibration. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> Specifies whether or not the factored form of the matrix A is +*> supplied on entry, and if not, whether the matrix A should be +*> equilibrated before it is factored. +*> = 'F': On entry, AFB contains the factored form of A. +*> If EQUED = 'Y', the matrix A has been equilibrated +*> with scaling factors given by S. AB and AFB will not +*> be modified. +*> = 'N': The matrix A will be copied to AFB and factored. +*> = 'E': The matrix A will be equilibrated if necessary, then +*> copied to AFB and factored. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right-hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array, except +*> if FACT = 'F' and EQUED = 'Y', then A must contain the +*> equilibrated matrix diag(S)*A*diag(S). The j-th column of A +*> is stored in the j-th column of the array AB as follows: +*> if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). +*> See below for further details. +*> +*> On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by +*> diag(S)*A*diag(S). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array A. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[in,out] AFB +*> \verbatim +*> AFB is DOUBLE PRECISION array, dimension (LDAFB,N) +*> If FACT = 'F', then AFB is an input argument and on entry +*> contains the triangular factor U or L from the Cholesky +*> factorization A = U**T*U or A = L*L**T of the band matrix +*> A, in the same storage format as A (see AB). If EQUED = 'Y', +*> then AFB is the factored form of the equilibrated matrix A. +*> +*> If FACT = 'N', then AFB is an output argument and on exit +*> returns the triangular factor U or L from the Cholesky +*> factorization A = U**T*U or A = L*L**T. +*> +*> If FACT = 'E', then AFB is an output argument and on exit +*> returns the triangular factor U or L from the Cholesky +*> factorization A = U**T*U or A = L*L**T of the equilibrated +*> matrix A (see the description of A for the form of the +*> equilibrated matrix). +*> \endverbatim +*> +*> \param[in] LDAFB +*> \verbatim +*> LDAFB is INTEGER +*> The leading dimension of the array AFB. LDAFB >= KD+1. +*> \endverbatim +*> +*> \param[in,out] EQUED +*> \verbatim +*> EQUED is CHARACTER*1 +*> Specifies the form of equilibration that was done. +*> = 'N': No equilibration (always true if FACT = 'N'). +*> = 'Y': Equilibration was done, i.e., A has been replaced by +*> diag(S) * A * diag(S). +*> EQUED is an input argument if FACT = 'F'; otherwise, it is an +*> output argument. +*> \endverbatim +*> +*> \param[in,out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N) +*> The scale factors for A; not accessed if EQUED = 'N'. S is +*> an input argument if FACT = 'F'; otherwise, S is an output +*> argument. If FACT = 'F' and EQUED = 'Y', each element of S +*> must be positive. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', +*> B is overwritten by diag(S) * B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to +*> the original system of equations. Note that if EQUED = 'Y', +*> A and B are modified on exit, and the solution to the +*> equilibrated system is inv(diag(S))*X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is 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. +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, and i is +*> <= N: the leading minor of order i of A is +*> not positive definite, so the factorization +*> could not be completed, and the solution has not +*> been computed. RCOND = 0 is returned. +*> = N+1: U is nonsingular, but RCOND is less than machine +*> precision, meaning that the matrix is singular +*> to working precision. Nevertheless, the +*> solution and error bounds are computed because +*> there are a number of situations where the +*> computed solution can be more accurate than the +*> value of RCOND would suggest. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleOTHERsolve +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The band storage scheme is illustrated by the following example, when +*> N = 6, KD = 2, and UPLO = 'U': +*> +*> Two-dimensional storage of the symmetric matrix A: +*> +*> a11 a12 a13 +*> a22 a23 a24 +*> a33 a34 a35 +*> a44 a45 a46 +*> a55 a56 +*> (aij=conjg(aji)) a66 +*> +*> Band storage of the upper triangle of A: +*> +*> * * a13 a24 a35 a46 +*> * a12 a23 a34 a45 a56 +*> a11 a22 a33 a44 a55 a66 +*> +*> Similarly, if UPLO = 'L' the format of A is as follows: +*> +*> a11 a22 a33 a44 a55 a66 +*> a21 a32 a43 a54 a65 * +*> a31 a42 a53 a64 * * +*> +*> Array elements marked * are not used by the routine. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, + $ EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, + $ WORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, UPLO + INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ BERR( * ), FERR( * ), S( * ), WORK( * ), + $ X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, RCEQU, UPPER + INTEGER I, INFEQU, J, J1, J2 + DOUBLE PRECISION AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSB + EXTERNAL LSAME, DLAMCH, DLANSB +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DLAQSB, DPBCON, DPBEQU, DPBRFS, + $ DPBTRF, DPBTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + UPPER = LSAME( UPLO, 'U' ) + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + RCEQU = .FALSE. + ELSE + RCEQU = LSAME( EQUED, 'Y' ) + 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.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KD.LT.0 ) THEN + INFO = -4 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -7 + ELSE IF( LDAFB.LT.KD+1 ) THEN + INFO = -9 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -10 + ELSE + IF( RCEQU ) THEN + SMIN = BIGNUM + SMAX = ZERO + DO 10 J = 1, N + SMIN = MIN( SMIN, S( J ) ) + SMAX = MAX( SMAX, S( J ) ) + 10 CONTINUE + IF( SMIN.LE.ZERO ) THEN + INFO = -11 + ELSE IF( N.GT.0 ) THEN + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + ELSE + SCOND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -15 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPBSVX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) + RCEQU = LSAME( EQUED, 'Y' ) + END IF + END IF +* +* Scale the right-hand side. +* + IF( RCEQU ) THEN + DO 30 J = 1, NRHS + DO 20 I = 1, N + B( I, J ) = S( I )*B( I, J ) + 20 CONTINUE + 30 CONTINUE + END IF +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the Cholesky factorization A = U**T *U or A = L*L**T. +* + IF( UPPER ) THEN + DO 40 J = 1, N + J1 = MAX( J-KD, 1 ) + CALL DCOPY( J-J1+1, AB( KD+1-J+J1, J ), 1, + $ AFB( KD+1-J+J1, J ), 1 ) + 40 CONTINUE + ELSE + DO 50 J = 1, N + J2 = MIN( J+KD, N ) + CALL DCOPY( J2-J+1, AB( 1, J ), 1, AFB( 1, J ), 1 ) + 50 CONTINUE + END IF +* + CALL DPBTRF( UPLO, N, KD, AFB, LDAFB, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 )THEN + RCOND = ZERO + RETURN + END IF + END IF +* +* Compute the norm of the matrix A. +* + ANORM = DLANSB( '1', UPLO, N, KD, AB, LDAB, WORK ) +* +* Compute the reciprocal of the condition number of A. +* + CALL DPBCON( UPLO, N, KD, AFB, LDAFB, ANORM, RCOND, WORK, IWORK, + $ INFO ) +* +* Compute the solution matrix X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DPBTRS( UPLO, N, KD, NRHS, AFB, LDAFB, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, + $ LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* Transform the solution matrix X to a solution of the original +* system. +* + IF( RCEQU ) THEN + DO 70 J = 1, NRHS + DO 60 I = 1, N + X( I, J ) = S( I )*X( I, J ) + 60 CONTINUE + 70 CONTINUE + DO 80 J = 1, NRHS + FERR( J ) = FERR( J ) / SCOND + 80 CONTINUE + END IF +* +* Set INFO = N+1 if the matrix is singular to working precision. +* + IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) + $ INFO = N + 1 +* + RETURN +* +* End of DPBSVX +* + END diff --git a/math/lapack/src/main/fortran/dpbtf2.f b/math/lapack/src/main/fortran/dpbtf2.f new file mode 100644 index 0000000000..fd385322b1 --- /dev/null +++ b/math/lapack/src/main/fortran/dpbtf2.f @@ -0,0 +1,263 @@ +*> \brief \b DPBTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite band matrix (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPBTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KD, LDAB, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPBTF2 computes the Cholesky factorization of a real symmetric +*> positive definite band matrix A. +*> +*> The factorization has the form +*> A = U**T * U , if UPLO = 'U', or +*> A = L * L**T, if UPLO = 'L', +*> where U is an upper triangular matrix, U**T is the transpose of U, and +*> L is lower triangular. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of super-diagonals of the matrix A if UPLO = 'U', +*> or the number of sub-diagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, if INFO = 0, the triangular factor U or L from the +*> Cholesky factorization A = U**T*U or A = L*L**T of the band +*> matrix A, in the same storage format as A. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> > 0: if INFO = k, the leading minor of order k is not +*> positive definite, and the factorization could not be +*> completed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The band storage scheme is illustrated by the following example, when +*> N = 6, KD = 2, and UPLO = 'U': +*> +*> On entry: On exit: +*> +*> * * a13 a24 a35 a46 * * u13 u24 u35 u46 +*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 +*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 +*> +*> Similarly, if UPLO = 'L' the format of A is as follows: +*> +*> On entry: On exit: +*> +*> a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 +*> a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * +*> a31 a42 a53 a64 * * l31 l42 l53 l64 * * +*> +*> Array elements marked * are not used by the routine. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KD, LDAB, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, KLD, KN + DOUBLE PRECISION AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSYR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, 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( KD.LT.0 ) THEN + INFO = -3 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPBTF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + KLD = MAX( 1, LDAB-1 ) +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization A = U**T*U. +* + DO 10 J = 1, N +* +* Compute U(J,J) and test for non-positive-definiteness. +* + AJJ = AB( KD+1, J ) + IF( AJJ.LE.ZERO ) + $ GO TO 30 + AJJ = SQRT( AJJ ) + AB( KD+1, J ) = AJJ +* +* Compute elements J+1:J+KN of row J and update the +* trailing submatrix within the band. +* + KN = MIN( KD, N-J ) + IF( KN.GT.0 ) THEN + CALL DSCAL( KN, ONE / AJJ, AB( KD, J+1 ), KLD ) + CALL DSYR( 'Upper', KN, -ONE, AB( KD, J+1 ), KLD, + $ AB( KD+1, J+1 ), KLD ) + END IF + 10 CONTINUE + ELSE +* +* Compute the Cholesky factorization A = L*L**T. +* + DO 20 J = 1, N +* +* Compute L(J,J) and test for non-positive-definiteness. +* + AJJ = AB( 1, J ) + IF( AJJ.LE.ZERO ) + $ GO TO 30 + AJJ = SQRT( AJJ ) + AB( 1, J ) = AJJ +* +* Compute elements J+1:J+KN of column J and update the +* trailing submatrix within the band. +* + KN = MIN( KD, N-J ) + IF( KN.GT.0 ) THEN + CALL DSCAL( KN, ONE / AJJ, AB( 2, J ), 1 ) + CALL DSYR( 'Lower', KN, -ONE, AB( 2, J ), 1, + $ AB( 1, J+1 ), KLD ) + END IF + 20 CONTINUE + END IF + RETURN +* + 30 CONTINUE + INFO = J + RETURN +* +* End of DPBTF2 +* + END diff --git a/math/lapack/src/main/fortran/dpbtrf.f b/math/lapack/src/main/fortran/dpbtrf.f new file mode 100644 index 0000000000..269e973628 --- /dev/null +++ b/math/lapack/src/main/fortran/dpbtrf.f @@ -0,0 +1,435 @@ +*> \brief \b DPBTRF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPBTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KD, LDAB, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPBTRF computes the Cholesky factorization of a real symmetric +*> positive definite band matrix A. +*> +*> The factorization has the form +*> A = U**T * U, if UPLO = 'U', or +*> A = L * L**T, if UPLO = 'L', +*> where U is an upper triangular matrix and L is lower triangular. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, if INFO = 0, the triangular factor U or L from the +*> Cholesky factorization A = U**T*U or A = L*L**T of the band +*> matrix A, in the same storage format as A. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the leading minor of order i is not +*> positive definite, and the factorization could not be +*> completed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The band storage scheme is illustrated by the following example, when +*> N = 6, KD = 2, and UPLO = 'U': +*> +*> On entry: On exit: +*> +*> * * a13 a24 a35 a46 * * u13 u24 u35 u46 +*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 +*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 +*> +*> Similarly, if UPLO = 'L' the format of A is as follows: +*> +*> On entry: On exit: +*> +*> a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 +*> a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * +*> a31 a42 a53 a64 * * l31 l42 l53 l64 * * +*> +*> Array elements marked * are not used by the routine. +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989 +* +* ===================================================================== + SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KD, LDAB, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NBMAX, LDWORK + PARAMETER ( NBMAX = 32, LDWORK = NBMAX+1 ) +* .. +* .. Local Scalars .. + INTEGER I, I2, I3, IB, II, J, JJ, NB +* .. +* .. Local Arrays .. + DOUBLE PRECISION WORK( LDWORK, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DPBTF2, DPOTF2, DSYRK, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( ( .NOT.LSAME( UPLO, 'U' ) ) .AND. + $ ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KD.LT.0 ) THEN + INFO = -3 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPBTRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment +* + NB = ILAENV( 1, 'DPBTRF', UPLO, N, KD, -1, -1 ) +* +* The block size must not exceed the semi-bandwidth KD, and must not +* exceed the limit set by the size of the local array WORK. +* + NB = MIN( NB, NBMAX ) +* + IF( NB.LE.1 .OR. NB.GT.KD ) THEN +* +* Use unblocked code +* + CALL DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) + ELSE +* +* Use blocked code +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Compute the Cholesky factorization of a symmetric band +* matrix, given the upper triangle of the matrix in band +* storage. +* +* Zero the upper triangle of the work array. +* + DO 20 J = 1, NB + DO 10 I = 1, J - 1 + WORK( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE +* +* Process the band matrix one diagonal block at a time. +* + DO 70 I = 1, N, NB + IB = MIN( NB, N-I+1 ) +* +* Factorize the diagonal block +* + CALL DPOTF2( UPLO, IB, AB( KD+1, I ), LDAB-1, II ) + IF( II.NE.0 ) THEN + INFO = I + II - 1 + GO TO 150 + END IF + IF( I+IB.LE.N ) THEN +* +* Update the relevant part of the trailing submatrix. +* If A11 denotes the diagonal block which has just been +* factorized, then we need to update the remaining +* blocks in the diagram: +* +* A11 A12 A13 +* A22 A23 +* A33 +* +* The numbers of rows and columns in the partitioning +* are IB, I2, I3 respectively. The blocks A12, A22 and +* A23 are empty if IB = KD. The upper triangle of A13 +* lies outside the band. +* + I2 = MIN( KD-IB, N-I-IB+1 ) + I3 = MIN( IB, N-I-KD+1 ) +* + IF( I2.GT.0 ) THEN +* +* Update A12 +* + CALL DTRSM( 'Left', 'Upper', 'Transpose', + $ 'Non-unit', IB, I2, ONE, AB( KD+1, I ), + $ LDAB-1, AB( KD+1-IB, I+IB ), LDAB-1 ) +* +* Update A22 +* + CALL DSYRK( 'Upper', 'Transpose', I2, IB, -ONE, + $ AB( KD+1-IB, I+IB ), LDAB-1, ONE, + $ AB( KD+1, I+IB ), LDAB-1 ) + END IF +* + IF( I3.GT.0 ) THEN +* +* Copy the lower triangle of A13 into the work array. +* + DO 40 JJ = 1, I3 + DO 30 II = JJ, IB + WORK( II, JJ ) = AB( II-JJ+1, JJ+I+KD-1 ) + 30 CONTINUE + 40 CONTINUE +* +* Update A13 (in the work array). +* + CALL DTRSM( 'Left', 'Upper', 'Transpose', + $ 'Non-unit', IB, I3, ONE, AB( KD+1, I ), + $ LDAB-1, WORK, LDWORK ) +* +* Update A23 +* + IF( I2.GT.0 ) + $ CALL DGEMM( 'Transpose', 'No Transpose', I2, I3, + $ IB, -ONE, AB( KD+1-IB, I+IB ), + $ LDAB-1, WORK, LDWORK, ONE, + $ AB( 1+IB, I+KD ), LDAB-1 ) +* +* Update A33 +* + CALL DSYRK( 'Upper', 'Transpose', I3, IB, -ONE, + $ WORK, LDWORK, ONE, AB( KD+1, I+KD ), + $ LDAB-1 ) +* +* Copy the lower triangle of A13 back into place. +* + DO 60 JJ = 1, I3 + DO 50 II = JJ, IB + AB( II-JJ+1, JJ+I+KD-1 ) = WORK( II, JJ ) + 50 CONTINUE + 60 CONTINUE + END IF + END IF + 70 CONTINUE + ELSE +* +* Compute the Cholesky factorization of a symmetric band +* matrix, given the lower triangle of the matrix in band +* storage. +* +* Zero the lower triangle of the work array. +* + DO 90 J = 1, NB + DO 80 I = J + 1, NB + WORK( I, J ) = ZERO + 80 CONTINUE + 90 CONTINUE +* +* Process the band matrix one diagonal block at a time. +* + DO 140 I = 1, N, NB + IB = MIN( NB, N-I+1 ) +* +* Factorize the diagonal block +* + CALL DPOTF2( UPLO, IB, AB( 1, I ), LDAB-1, II ) + IF( II.NE.0 ) THEN + INFO = I + II - 1 + GO TO 150 + END IF + IF( I+IB.LE.N ) THEN +* +* Update the relevant part of the trailing submatrix. +* If A11 denotes the diagonal block which has just been +* factorized, then we need to update the remaining +* blocks in the diagram: +* +* A11 +* A21 A22 +* A31 A32 A33 +* +* The numbers of rows and columns in the partitioning +* are IB, I2, I3 respectively. The blocks A21, A22 and +* A32 are empty if IB = KD. The lower triangle of A31 +* lies outside the band. +* + I2 = MIN( KD-IB, N-I-IB+1 ) + I3 = MIN( IB, N-I-KD+1 ) +* + IF( I2.GT.0 ) THEN +* +* Update A21 +* + CALL DTRSM( 'Right', 'Lower', 'Transpose', + $ 'Non-unit', I2, IB, ONE, AB( 1, I ), + $ LDAB-1, AB( 1+IB, I ), LDAB-1 ) +* +* Update A22 +* + CALL DSYRK( 'Lower', 'No Transpose', I2, IB, -ONE, + $ AB( 1+IB, I ), LDAB-1, ONE, + $ AB( 1, I+IB ), LDAB-1 ) + END IF +* + IF( I3.GT.0 ) THEN +* +* Copy the upper triangle of A31 into the work array. +* + DO 110 JJ = 1, IB + DO 100 II = 1, MIN( JJ, I3 ) + WORK( II, JJ ) = AB( KD+1-JJ+II, JJ+I-1 ) + 100 CONTINUE + 110 CONTINUE +* +* Update A31 (in the work array). +* + CALL DTRSM( 'Right', 'Lower', 'Transpose', + $ 'Non-unit', I3, IB, ONE, AB( 1, I ), + $ LDAB-1, WORK, LDWORK ) +* +* Update A32 +* + IF( I2.GT.0 ) + $ CALL DGEMM( 'No transpose', 'Transpose', I3, I2, + $ IB, -ONE, WORK, LDWORK, + $ AB( 1+IB, I ), LDAB-1, ONE, + $ AB( 1+KD-IB, I+IB ), LDAB-1 ) +* +* Update A33 +* + CALL DSYRK( 'Lower', 'No Transpose', I3, IB, -ONE, + $ WORK, LDWORK, ONE, AB( 1, I+KD ), + $ LDAB-1 ) +* +* Copy the upper triangle of A31 back into place. +* + DO 130 JJ = 1, IB + DO 120 II = 1, MIN( JJ, I3 ) + AB( KD+1-JJ+II, JJ+I-1 ) = WORK( II, JJ ) + 120 CONTINUE + 130 CONTINUE + END IF + END IF + 140 CONTINUE + END IF + END IF + RETURN +* + 150 CONTINUE + RETURN +* +* End of DPBTRF +* + END diff --git a/math/lapack/src/main/fortran/dpbtrs.f b/math/lapack/src/main/fortran/dpbtrs.f new file mode 100644 index 0000000000..08e437399c --- /dev/null +++ b/math/lapack/src/main/fortran/dpbtrs.f @@ -0,0 +1,220 @@ +*> \brief \b DPBTRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPBTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KD, LDAB, LDB, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPBTRS solves a system of linear equations A*X = B with a symmetric +*> positive definite band matrix A using the Cholesky factorization +*> A = U**T*U or A = L*L**T computed by DPBTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangular factor stored in AB; +*> = 'L': Lower triangular factor stored in AB. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> The triangular factor U or L from the Cholesky factorization +*> A = U**T*U or A = L*L**T of the band matrix A, stored in the +*> first KD+1 rows of the array. The j-th column of U or L is +*> stored in the j-th column of the array AB as follows: +*> if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KD, LDAB, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DTBSV, 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( KD.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPBTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B where A = U**T *U. +* + DO 10 J = 1, NRHS +* +* Solve U**T *X = B, overwriting B with X. +* + CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KD, AB, + $ LDAB, B( 1, J ), 1 ) +* +* Solve U*X = B, overwriting B with X. +* + CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KD, AB, + $ LDAB, B( 1, J ), 1 ) + 10 CONTINUE + ELSE +* +* Solve A*X = B where A = L*L**T. +* + DO 20 J = 1, NRHS +* +* Solve L*X = B, overwriting B with X. +* + CALL DTBSV( 'Lower', 'No transpose', 'Non-unit', N, KD, AB, + $ LDAB, B( 1, J ), 1 ) +* +* Solve L**T *X = B, overwriting B with X. +* + CALL DTBSV( 'Lower', 'Transpose', 'Non-unit', N, KD, AB, + $ LDAB, B( 1, J ), 1 ) + 20 CONTINUE + END IF +* + RETURN +* +* End of DPBTRS +* + END diff --git a/math/lapack/src/main/fortran/dpftrf.f b/math/lapack/src/main/fortran/dpftrf.f new file mode 100644 index 0000000000..b460f2a5da --- /dev/null +++ b/math/lapack/src/main/fortran/dpftrf.f @@ -0,0 +1,457 @@ +*> \brief \b DPFTRF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPFTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPFTRF( TRANSR, UPLO, N, A, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANSR, UPLO +* INTEGER N, INFO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( 0: * ) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPFTRF computes the Cholesky factorization of a real symmetric +*> positive definite matrix A. +*> +*> The factorization has the form +*> A = U**T * U, if UPLO = 'U', or +*> A = L * L**T, if UPLO = 'L', +*> where U is an upper triangular matrix and L is lower triangular. +*> +*> This is the block version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSR +*> \verbatim +*> TRANSR is CHARACTER*1 +*> = 'N': The Normal TRANSR of RFP A is stored; +*> = 'T': The Transpose TRANSR of RFP A is stored. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of RFP A is stored; +*> = 'L': Lower triangle of RFP A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ); +*> On entry, the symmetric matrix A in RFP format. RFP format is +*> described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' +*> then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is +*> (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is +*> the transpose of RFP A as defined when +*> TRANSR = 'N'. The contents of RFP A are defined by UPLO as +*> follows: If UPLO = 'U' the RFP A contains the NT elements of +*> upper packed A. If UPLO = 'L' the RFP A contains the elements +*> of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = +*> 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N +*> is odd. See the Note below for more details. +*> +*> On exit, if INFO = 0, the factor U or L from the Cholesky +*> factorization RFP A = U**T*U or RFP A = L*L**T. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the leading minor of order i is not +*> positive definite, and the factorization could not be +*> completed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> We first consider Rectangular Full Packed (RFP) Format when N is +*> even. We give an example where N = 6. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 05 00 +*> 11 12 13 14 15 10 11 +*> 22 23 24 25 20 21 22 +*> 33 34 35 30 31 32 33 +*> 44 45 40 41 42 43 44 +*> 55 50 51 52 53 54 55 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(4:6,0:2) consists of +*> the transpose of the first three columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:2,0:2) consists of +*> the transpose of the last three columns of AP lower. +*> This covers the case N even and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 03 04 05 33 43 53 +*> 13 14 15 00 44 54 +*> 23 24 25 10 11 55 +*> 33 34 35 20 21 22 +*> 00 44 45 30 31 32 +*> 01 11 55 40 41 42 +*> 02 12 22 50 51 52 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> +*> RFP A RFP A +*> +*> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +*> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +*> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +*> +*> +*> We then consider Rectangular Full Packed (RFP) Format when N is +*> odd. We give an example where N = 5. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 00 +*> 11 12 13 14 10 11 +*> 22 23 24 20 21 22 +*> 33 34 30 31 32 33 +*> 44 40 41 42 43 44 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(3:4,0:1) consists of +*> the transpose of the first two columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:1,1:2) consists of +*> the transpose of the last two columns of AP lower. +*> This covers the case N odd and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 02 03 04 00 33 43 +*> 12 13 14 10 11 44 +*> 22 23 24 20 21 22 +*> 00 33 34 30 31 32 +*> 01 11 44 40 41 42 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> RFP A RFP A +*> +*> 02 12 22 00 01 00 10 20 30 40 50 +*> 03 13 23 33 11 33 11 21 31 41 51 +*> 04 14 24 34 44 43 44 22 32 42 52 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DPFTRF( TRANSR, UPLO, N, A, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER N, INFO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( 0: * ) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSYRK, DPOTRF, DTRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPFTRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + ELSE + NISODD = .TRUE. + END IF +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1) +* + CALL DPOTRF( 'L', N1, A( 0 ), N, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CALL DTRSM( 'R', 'L', 'T', 'N', N2, N1, ONE, A( 0 ), N, + $ A( N1 ), N ) + CALL DSYRK( 'U', 'N', N2, N1, -ONE, A( N1 ), N, ONE, + $ A( N ), N ) + CALL DPOTRF( 'U', N2, A( N ), N, INFO ) + IF( INFO.GT.0 ) + $ INFO = INFO + N1 +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + CALL DPOTRF( 'L', N1, A( N2 ), N, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CALL DTRSM( 'L', 'L', 'N', 'N', N1, N2, ONE, A( N2 ), N, + $ A( 0 ), N ) + CALL DSYRK( 'U', 'T', N2, N1, -ONE, A( 0 ), N, ONE, + $ A( N1 ), N ) + CALL DPOTRF( 'U', N2, A( N1 ), N, INFO ) + IF( INFO.GT.0 ) + $ INFO = INFO + N1 +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) +* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 +* + CALL DPOTRF( 'U', N1, A( 0 ), N1, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CALL DTRSM( 'L', 'U', 'T', 'N', N1, N2, ONE, A( 0 ), N1, + $ A( N1*N1 ), N1 ) + CALL DSYRK( 'L', 'T', N2, N1, -ONE, A( N1*N1 ), N1, ONE, + $ A( 1 ), N1 ) + CALL DPOTRF( 'L', N2, A( 1 ), N1, INFO ) + IF( INFO.GT.0 ) + $ INFO = INFO + N1 +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) +* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 +* + CALL DPOTRF( 'U', N1, A( N2*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CALL DTRSM( 'R', 'U', 'N', 'N', N2, N1, ONE, A( N2*N2 ), + $ N2, A( 0 ), N2 ) + CALL DSYRK( 'L', 'N', N2, N1, -ONE, A( 0 ), N2, ONE, + $ A( N1*N2 ), N2 ) + CALL DPOTRF( 'L', N2, A( N1*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + $ INFO = INFO + N1 +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + CALL DPOTRF( 'L', K, A( 1 ), N+1, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CALL DTRSM( 'R', 'L', 'T', 'N', K, K, ONE, A( 1 ), N+1, + $ A( K+1 ), N+1 ) + CALL DSYRK( 'U', 'N', K, K, -ONE, A( K+1 ), N+1, ONE, + $ A( 0 ), N+1 ) + CALL DPOTRF( 'U', K, A( 0 ), N+1, INFO ) + IF( INFO.GT.0 ) + $ INFO = INFO + K +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + CALL DPOTRF( 'L', K, A( K+1 ), N+1, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CALL DTRSM( 'L', 'L', 'N', 'N', K, K, ONE, A( K+1 ), + $ N+1, A( 0 ), N+1 ) + CALL DSYRK( 'U', 'T', K, K, -ONE, A( 0 ), N+1, ONE, + $ A( K ), N+1 ) + CALL DPOTRF( 'U', K, A( K ), N+1, INFO ) + IF( INFO.GT.0 ) + $ INFO = INFO + K +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + CALL DPOTRF( 'U', K, A( 0+K ), K, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CALL DTRSM( 'L', 'U', 'T', 'N', K, K, ONE, A( K ), N1, + $ A( K*( K+1 ) ), K ) + CALL DSYRK( 'L', 'T', K, K, -ONE, A( K*( K+1 ) ), K, ONE, + $ A( 0 ), K ) + CALL DPOTRF( 'L', K, A( 0 ), K, INFO ) + IF( INFO.GT.0 ) + $ INFO = INFO + K +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + CALL DPOTRF( 'U', K, A( K*( K+1 ) ), K, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CALL DTRSM( 'R', 'U', 'N', 'N', K, K, ONE, + $ A( K*( K+1 ) ), K, A( 0 ), K ) + CALL DSYRK( 'L', 'N', K, K, -ONE, A( 0 ), K, ONE, + $ A( K*K ), K ) + CALL DPOTRF( 'L', K, A( K*K ), K, INFO ) + IF( INFO.GT.0 ) + $ INFO = INFO + K +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of DPFTRF +* + END diff --git a/math/lapack/src/main/fortran/dpftri.f b/math/lapack/src/main/fortran/dpftri.f new file mode 100644 index 0000000000..adbbfa8ad5 --- /dev/null +++ b/math/lapack/src/main/fortran/dpftri.f @@ -0,0 +1,423 @@ +*> \brief \b DPFTRI +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPFTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPFTRI( TRANSR, UPLO, N, A, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANSR, UPLO +* INTEGER INFO, N +* .. Array Arguments .. +* DOUBLE PRECISION A( 0: * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPFTRI computes the inverse of a (real) symmetric positive definite +*> matrix A using the Cholesky factorization A = U**T*U or A = L*L**T +*> computed by DPFTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSR +*> \verbatim +*> TRANSR is CHARACTER*1 +*> = 'N': The Normal TRANSR of RFP A is stored; +*> = 'T': The Transpose TRANSR of RFP A is stored. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ) +*> On entry, the symmetric matrix A in RFP format. RFP format is +*> described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' +*> then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is +*> (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is +*> the transpose of RFP A as defined when +*> TRANSR = 'N'. The contents of RFP A are defined by UPLO as +*> follows: If UPLO = 'U' the RFP A contains the nt elements of +*> upper packed A. If UPLO = 'L' the RFP A contains the elements +*> of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = +*> 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N +*> is odd. See the Note below for more details. +*> +*> On exit, the symmetric inverse of the original matrix, in the +*> same storage format. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the (i,i) element of the factor U or L is +*> zero, and the inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> We first consider Rectangular Full Packed (RFP) Format when N is +*> even. We give an example where N = 6. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 05 00 +*> 11 12 13 14 15 10 11 +*> 22 23 24 25 20 21 22 +*> 33 34 35 30 31 32 33 +*> 44 45 40 41 42 43 44 +*> 55 50 51 52 53 54 55 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(4:6,0:2) consists of +*> the transpose of the first three columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:2,0:2) consists of +*> the transpose of the last three columns of AP lower. +*> This covers the case N even and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 03 04 05 33 43 53 +*> 13 14 15 00 44 54 +*> 23 24 25 10 11 55 +*> 33 34 35 20 21 22 +*> 00 44 45 30 31 32 +*> 01 11 55 40 41 42 +*> 02 12 22 50 51 52 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> +*> RFP A RFP A +*> +*> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +*> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +*> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +*> +*> +*> We then consider Rectangular Full Packed (RFP) Format when N is +*> odd. We give an example where N = 5. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 00 +*> 11 12 13 14 10 11 +*> 22 23 24 20 21 22 +*> 33 34 30 31 32 33 +*> 44 40 41 42 43 44 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(3:4,0:1) consists of +*> the transpose of the first two columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:1,1:2) consists of +*> the transpose of the last two columns of AP lower. +*> This covers the case N odd and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 02 03 04 00 33 43 +*> 12 13 14 10 11 44 +*> 22 23 24 20 21 22 +*> 00 33 34 30 31 32 +*> 01 11 44 40 41 42 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> RFP A RFP A +*> +*> 02 12 22 00 01 00 10 20 30 40 50 +*> 03 13 23 33 11 33 11 21 31 41 51 +*> 04 14 24 34 44 43 44 22 32 42 52 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DPFTRI( TRANSR, UPLO, N, A, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N +* .. Array Arguments .. + DOUBLE PRECISION A( 0: * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DTFTRI, DLAUUM, DTRMM, DSYRK +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPFTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Invert the triangular Cholesky factor U or L. +* + CALL DTFTRI( TRANSR, UPLO, 'N', N, A, INFO ) + IF( INFO.GT.0 ) + $ RETURN +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + ELSE + NISODD = .TRUE. + END IF +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* Start execution of triangular matrix multiply: inv(U)*inv(U)^C or +* inv(L)^C*inv(L). There are eight cases. +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:N1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(N1,0) +* T1 -> a(0), T2 -> a(n), S -> a(N1) +* + CALL DLAUUM( 'L', N1, A( 0 ), N, INFO ) + CALL DSYRK( 'L', 'T', N1, N2, ONE, A( N1 ), N, ONE, + $ A( 0 ), N ) + CALL DTRMM( 'L', 'U', 'N', 'N', N2, N1, ONE, A( N ), N, + $ A( N1 ), N ) + CALL DLAUUM( 'U', N2, A( N ), N, INFO ) +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:N2-1) +* T1 -> a(N1+1,0), T2 -> a(N1,0), S -> a(0,0) +* T1 -> a(N2), T2 -> a(N1), S -> a(0) +* + CALL DLAUUM( 'L', N1, A( N2 ), N, INFO ) + CALL DSYRK( 'L', 'N', N1, N2, ONE, A( 0 ), N, ONE, + $ A( N2 ), N ) + CALL DTRMM( 'R', 'U', 'T', 'N', N1, N2, ONE, A( N1 ), N, + $ A( 0 ), N ) + CALL DLAUUM( 'U', N2, A( N1 ), N, INFO ) +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE, and N is odd +* T1 -> a(0), T2 -> a(1), S -> a(0+N1*N1) +* + CALL DLAUUM( 'U', N1, A( 0 ), N1, INFO ) + CALL DSYRK( 'U', 'N', N1, N2, ONE, A( N1*N1 ), N1, ONE, + $ A( 0 ), N1 ) + CALL DTRMM( 'R', 'L', 'N', 'N', N1, N2, ONE, A( 1 ), N1, + $ A( N1*N1 ), N1 ) + CALL DLAUUM( 'L', N2, A( 1 ), N1, INFO ) +* + ELSE +* +* SRPA for UPPER, TRANSPOSE, and N is odd +* T1 -> a(0+N2*N2), T2 -> a(0+N1*N2), S -> a(0) +* + CALL DLAUUM( 'U', N1, A( N2*N2 ), N2, INFO ) + CALL DSYRK( 'U', 'T', N1, N2, ONE, A( 0 ), N2, ONE, + $ A( N2*N2 ), N2 ) + CALL DTRMM( 'L', 'L', 'T', 'N', N2, N1, ONE, A( N1*N2 ), + $ N2, A( 0 ), N2 ) + CALL DLAUUM( 'L', N2, A( N1*N2 ), N2, INFO ) +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + CALL DLAUUM( 'L', K, A( 1 ), N+1, INFO ) + CALL DSYRK( 'L', 'T', K, K, ONE, A( K+1 ), N+1, ONE, + $ A( 1 ), N+1 ) + CALL DTRMM( 'L', 'U', 'N', 'N', K, K, ONE, A( 0 ), N+1, + $ A( K+1 ), N+1 ) + CALL DLAUUM( 'U', K, A( 0 ), N+1, INFO ) +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + CALL DLAUUM( 'L', K, A( K+1 ), N+1, INFO ) + CALL DSYRK( 'L', 'N', K, K, ONE, A( 0 ), N+1, ONE, + $ A( K+1 ), N+1 ) + CALL DTRMM( 'R', 'U', 'T', 'N', K, K, ONE, A( K ), N+1, + $ A( 0 ), N+1 ) + CALL DLAUUM( 'U', K, A( K ), N+1, INFO ) +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE, and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1), +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + CALL DLAUUM( 'U', K, A( K ), K, INFO ) + CALL DSYRK( 'U', 'N', K, K, ONE, A( K*( K+1 ) ), K, ONE, + $ A( K ), K ) + CALL DTRMM( 'R', 'L', 'N', 'N', K, K, ONE, A( 0 ), K, + $ A( K*( K+1 ) ), K ) + CALL DLAUUM( 'L', K, A( 0 ), K, INFO ) +* + ELSE +* +* SRPA for UPPER, TRANSPOSE, and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0), +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + CALL DLAUUM( 'U', K, A( K*( K+1 ) ), K, INFO ) + CALL DSYRK( 'U', 'T', K, K, ONE, A( 0 ), K, ONE, + $ A( K*( K+1 ) ), K ) + CALL DTRMM( 'L', 'L', 'T', 'N', K, K, ONE, A( K*K ), K, + $ A( 0 ), K ) + CALL DLAUUM( 'L', K, A( K*K ), K, INFO ) +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of DPFTRI +* + END diff --git a/math/lapack/src/main/fortran/dpftrs.f b/math/lapack/src/main/fortran/dpftrs.f new file mode 100644 index 0000000000..9c325064ea --- /dev/null +++ b/math/lapack/src/main/fortran/dpftrs.f @@ -0,0 +1,280 @@ +*> \brief \b DPFTRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPFTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANSR, UPLO +* INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( 0: * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPFTRS solves a system of linear equations A*X = B with a symmetric +*> positive definite matrix A using the Cholesky factorization +*> A = U**T*U or A = L*L**T computed by DPFTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSR +*> \verbatim +*> TRANSR is CHARACTER*1 +*> = 'N': The Normal TRANSR of RFP A is stored; +*> = 'T': The Transpose TRANSR of RFP A is stored. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of RFP A is stored; +*> = 'L': Lower triangle of RFP A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ). +*> The triangular factor U or L from the Cholesky factorization +*> of RFP A = U**T*U or RFP A = L*L**T, as computed by DPFTRF. +*> See note below for more details about RFP A. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> We first consider Rectangular Full Packed (RFP) Format when N is +*> even. We give an example where N = 6. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 05 00 +*> 11 12 13 14 15 10 11 +*> 22 23 24 25 20 21 22 +*> 33 34 35 30 31 32 33 +*> 44 45 40 41 42 43 44 +*> 55 50 51 52 53 54 55 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(4:6,0:2) consists of +*> the transpose of the first three columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:2,0:2) consists of +*> the transpose of the last three columns of AP lower. +*> This covers the case N even and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 03 04 05 33 43 53 +*> 13 14 15 00 44 54 +*> 23 24 25 10 11 55 +*> 33 34 35 20 21 22 +*> 00 44 45 30 31 32 +*> 01 11 55 40 41 42 +*> 02 12 22 50 51 52 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> +*> RFP A RFP A +*> +*> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +*> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +*> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +*> +*> +*> We then consider Rectangular Full Packed (RFP) Format when N is +*> odd. We give an example where N = 5. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 00 +*> 11 12 13 14 10 11 +*> 22 23 24 20 21 22 +*> 33 34 30 31 32 33 +*> 44 40 41 42 43 44 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(3:4,0:1) consists of +*> the transpose of the first two columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:1,1:2) consists of +*> the transpose of the last two columns of AP lower. +*> This covers the case N odd and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 02 03 04 00 33 43 +*> 12 13 14 10 11 44 +*> 22 23 24 20 21 22 +*> 00 33 34 30 31 32 +*> 01 11 44 40 41 42 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> RFP A RFP A +*> +*> 02 12 22 00 01 00 10 20 30 40 50 +*> 03 13 23 33 11 33 11 21 31 41 51 +*> 04 14 24 34 44 43 44 22 32 42 52 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( 0: * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NORMALTRANSR +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DTFSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPFTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* +* start execution: there are two triangular solves +* + IF( LOWER ) THEN + CALL DTFSM( TRANSR, 'L', UPLO, 'N', 'N', N, NRHS, ONE, A, B, + $ LDB ) + CALL DTFSM( TRANSR, 'L', UPLO, 'T', 'N', N, NRHS, ONE, A, B, + $ LDB ) + ELSE + CALL DTFSM( TRANSR, 'L', UPLO, 'T', 'N', N, NRHS, ONE, A, B, + $ LDB ) + CALL DTFSM( TRANSR, 'L', UPLO, 'N', 'N', N, NRHS, ONE, A, B, + $ LDB ) + END IF +* + RETURN +* +* End of DPFTRS +* + END diff --git a/math/lapack/src/main/fortran/dpocon.f b/math/lapack/src/main/fortran/dpocon.f new file mode 100644 index 0000000000..20e9aff6a0 --- /dev/null +++ b/math/lapack/src/main/fortran/dpocon.f @@ -0,0 +1,253 @@ +*> \brief \b DPOCON +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPOCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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))). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is DOUBLE PRECISION +*> The 1-norm (or infinity-norm) of the symmetric matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePOcomputational +* +* ===================================================================== + SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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**T). +* + 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**T). +* + 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/math/lapack/src/main/fortran/dpoequ.f b/math/lapack/src/main/fortran/dpoequ.f new file mode 100644 index 0000000000..eb150713dc --- /dev/null +++ b/math/lapack/src/main/fortran/dpoequ.f @@ -0,0 +1,205 @@ +*> \brief \b DPOEQU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPOEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, N +* DOUBLE PRECISION AMAX, SCOND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), S( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPOEQU computes row and column scalings intended to equilibrate a +*> symmetric positive definite matrix A and reduce its condition number +*> (with respect to the two-norm). S contains the scale factors, +*> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with +*> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This +*> choice of S puts the condition number of B within a factor N of the +*> smallest possible condition number over all possible diagonal +*> scalings. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The N-by-N symmetric positive definite matrix whose scaling +*> factors are to be computed. Only the diagonal elements of A +*> are referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, S contains the scale factors for A. +*> \endverbatim +*> +*> \param[out] SCOND +*> \verbatim +*> SCOND is DOUBLE PRECISION +*> If INFO = 0, S contains the ratio of the smallest S(i) to +*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too +*> large nor too small, it is not worth scaling by S. +*> \endverbatim +*> +*> \param[out] AMAX +*> \verbatim +*> AMAX is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the i-th diagonal element is nonpositive. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePOcomputational +* +* ===================================================================== + SUBROUTINE DPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, N + DOUBLE PRECISION AMAX, SCOND +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), S( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION SMIN +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPOEQU', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + SCOND = ONE + AMAX = ZERO + RETURN + END IF +* +* Find the minimum and maximum diagonal elements. +* + S( 1 ) = A( 1, 1 ) + SMIN = S( 1 ) + AMAX = S( 1 ) + DO 10 I = 2, N + S( I ) = A( I, I ) + SMIN = MIN( SMIN, S( I ) ) + AMAX = MAX( AMAX, S( I ) ) + 10 CONTINUE +* + IF( SMIN.LE.ZERO ) THEN +* +* Find the first non-positive diagonal element and return. +* + DO 20 I = 1, N + IF( S( I ).LE.ZERO ) THEN + INFO = I + RETURN + END IF + 20 CONTINUE + ELSE +* +* Set the scale factors to the reciprocals +* of the diagonal elements. +* + DO 30 I = 1, N + S( I ) = ONE / SQRT( S( I ) ) + 30 CONTINUE +* +* Compute SCOND = min(S(I)) / max(S(I)) +* + SCOND = SQRT( SMIN ) / SQRT( AMAX ) + END IF + RETURN +* +* End of DPOEQU +* + END diff --git a/math/lapack/src/main/fortran/dpoequb.f b/math/lapack/src/main/fortran/dpoequb.f new file mode 100644 index 0000000000..fbcc6fe3e4 --- /dev/null +++ b/math/lapack/src/main/fortran/dpoequb.f @@ -0,0 +1,221 @@ +*> \brief \b DPOEQUB +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPOEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, N +* DOUBLE PRECISION AMAX, SCOND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), S( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPOEQUB computes row and column scalings intended to equilibrate a +*> symmetric positive definite matrix A and reduce its condition number +*> (with respect to the two-norm). S contains the scale factors, +*> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with +*> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This +*> choice of S puts the condition number of B within a factor N of the +*> smallest possible condition number over all possible diagonal +*> scalings. +*> +*> This routine differs from DPOEQU by restricting the scaling factors +*> to a power of the radix. Barring over- and underflow, scaling by +*> these factors introduces no additional rounding errors. However, the +*> scaled diagonal entries are no longer approximately 1 but lie +*> between sqrt(radix) and 1/sqrt(radix). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The N-by-N symmetric positive definite matrix whose scaling +*> factors are to be computed. Only the diagonal elements of A +*> are referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, S contains the scale factors for A. +*> \endverbatim +*> +*> \param[out] SCOND +*> \verbatim +*> SCOND is DOUBLE PRECISION +*> If INFO = 0, S contains the ratio of the smallest S(i) to +*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too +*> large nor too small, it is not worth scaling by S. +*> \endverbatim +*> +*> \param[out] AMAX +*> \verbatim +*> AMAX is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the i-th diagonal element is nonpositive. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePOcomputational +* +* ===================================================================== + SUBROUTINE DPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, N + DOUBLE PRECISION AMAX, SCOND +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), S( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION SMIN, BASE, TMP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT, LOG, INT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* +* Positive definite only performs 1 pass of equilibration. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPOEQUB', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + SCOND = ONE + AMAX = ZERO + RETURN + END IF + + BASE = DLAMCH( 'B' ) + TMP = -0.5D+0 / LOG ( BASE ) +* +* Find the minimum and maximum diagonal elements. +* + S( 1 ) = A( 1, 1 ) + SMIN = S( 1 ) + AMAX = S( 1 ) + DO 10 I = 2, N + S( I ) = A( I, I ) + SMIN = MIN( SMIN, S( I ) ) + AMAX = MAX( AMAX, S( I ) ) + 10 CONTINUE +* + IF( SMIN.LE.ZERO ) THEN +* +* Find the first non-positive diagonal element and return. +* + DO 20 I = 1, N + IF( S( I ).LE.ZERO ) THEN + INFO = I + RETURN + END IF + 20 CONTINUE + ELSE +* +* Set the scale factors to the reciprocals +* of the diagonal elements. +* + DO 30 I = 1, N + S( I ) = BASE ** INT( TMP * LOG( S( I ) ) ) + 30 CONTINUE +* +* Compute SCOND = min(S(I)) / max(S(I)). +* + SCOND = SQRT( SMIN ) / SQRT( AMAX ) + END IF +* + RETURN +* +* End of DPOEQUB +* + END diff --git a/math/lapack/src/main/fortran/dporfs.f b/math/lapack/src/main/fortran/dporfs.f new file mode 100644 index 0000000000..8fc74fde14 --- /dev/null +++ b/math/lapack/src/main/fortran/dporfs.f @@ -0,0 +1,430 @@ +*> \brief \b DPORFS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPORFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, +* LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), +* $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPORFS improves the computed solution to a system of linear +*> equations when the coefficient matrix is symmetric positive definite, +*> and provides error bounds and backward error estimates for the +*> solution. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> The triangular factor U or L from the Cholesky factorization +*> A = U**T*U or A = L*L**T, as computed by DPOTRF. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> On entry, the solution matrix X, as computed by DPOTRS. +*> On exit, the improved solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> ITMAX is the maximum number of steps of iterative refinement. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePOcomputational +* +* ===================================================================== + SUBROUTINE DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, + $ LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. 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 UPPER + 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, DLACN2, DPOTRS, DSYMV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. 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( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPORFS', -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 +* +* 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 - A * X +* + CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) + CALL DSYMV( UPLO, 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(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(A)*abs(X) + abs(B). +* + IF( UPPER ) THEN + DO 50 K = 1, N + S = ZERO + XK = ABS( X( K, J ) ) + DO 40 I = 1, K - 1 + WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK + S = S + ABS( A( I, K ) )*ABS( X( I, J ) ) + 40 CONTINUE + WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S + 50 CONTINUE + ELSE + DO 70 K = 1, N + S = ZERO + XK = ABS( X( K, J ) ) + WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + DO 60 I = K + 1, N + WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK + 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 DPOTRS( UPLO, N, 1, AF, LDAF, 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(A))* +* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) +* +* where +* norm(Z) is the magnitude of the largest component of Z +* inv(A) is the inverse of A +* abs(Z) is the componentwise absolute value of the matrix or +* vector Z +* NZ is the maximum number of nonzeros in any row of A, plus 1 +* EPS is machine epsilon +* +* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) +* is incremented by SAFE1 if the i-th component of +* abs(A)*abs(X) + abs(B) is less than SAFE2. +* +* Use DLACN2 to estimate the infinity-norm of the matrix +* inv(A) * diag(W), +* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) +* + 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(A**T). +* + CALL DPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO ) + DO 110 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 110 CONTINUE + ELSE IF( KASE.EQ.2 ) THEN +* +* Multiply by inv(A)*diag(W). +* + DO 120 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 120 CONTINUE + CALL DPOTRS( UPLO, N, 1, AF, LDAF, 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 DPORFS +* + END diff --git a/math/lapack/src/main/fortran/dporfsx.f b/math/lapack/src/main/fortran/dporfsx.f new file mode 100644 index 0000000000..53724925eb --- /dev/null +++ b/math/lapack/src/main/fortran/dporfsx.f @@ -0,0 +1,693 @@ +*> \brief \b DPORFSX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPORFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, +* LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, +* ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, EQUED +* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, +* $ N_ERR_BNDS +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), +* $ X( LDX, * ), WORK( * ) +* DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), +* $ ERR_BNDS_NORM( NRHS, * ), +* $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPORFSX improves the computed solution to a system of linear +*> equations when the coefficient matrix is symmetric positive +*> definite, and provides error bounds and backward error estimates +*> for the solution. In addition to normwise error bound, the code +*> provides maximum componentwise error bound if possible. See +*> comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the +*> error bounds. +*> +*> The original system of linear equations may have been equilibrated +*> before calling this routine, as described by arguments EQUED and S +*> below. In this case, the solution and error bounds returned are +*> for the original unequilibrated system. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> Some optional parameters are bundled in the PARAMS array. These +*> settings determine how refinement is performed, but often the +*> defaults are acceptable. If the defaults are acceptable, users +*> can pass NPARAMS = 0 which prevents the source code from accessing +*> the PARAMS argument. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] EQUED +*> \verbatim +*> EQUED is CHARACTER*1 +*> Specifies the form of equilibration that was done to A +*> before calling this routine. This is needed to compute +*> the solution and error bounds correctly. +*> = 'N': No equilibration +*> = 'Y': Both row and column equilibration, i.e., A has been +*> replaced by diag(S) * A * diag(S). +*> The right hand side B has been changed accordingly. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> The triangular factor U or L from the Cholesky factorization +*> A = U**T*U or A = L*L**T, as computed by DPOTRF. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N) +*> The row scale factors for A. If EQUED = 'Y', A is multiplied on +*> the left and right by diag(S). S is an input argument if FACT = +*> 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +*> = 'Y', each element of S must be positive. If S is output, each +*> element of S is a power of the radix. If S is input, each element +*> of S should be a power of the radix to ensure a reliable solution +*> and error estimates. Scaling by powers of the radix does not cause +*> rounding errors unless the result underflows or overflows. +*> Rounding errors during scaling lead to refining with a matrix that +*> is not equivalent to the input matrix, producing error estimates +*> that may not be reliable. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> On entry, the solution matrix X, as computed by DGETRS. +*> On exit, the improved solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> Reciprocal scaled condition number. This is an estimate of the +*> reciprocal Skeel condition number of the matrix A after +*> equilibration (if done). If this is less than the machine +*> precision (in particular, if it is zero), the matrix is singular +*> to working precision. Note that the error may still be small even +*> if this number is very small and the matrix appears ill- +*> conditioned. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is DOUBLE PRECISION array, dimension (NRHS) +*> Componentwise relative backward error. This is the +*> componentwise relative backward error of each solution vector X(j) +*> (i.e., the smallest relative change in any element of A or B that +*> makes X(j) an exact solution). +*> \endverbatim +*> +*> \param[in] N_ERR_BNDS +*> \verbatim +*> N_ERR_BNDS is INTEGER +*> Number of error bounds to return for each right hand side +*> and each type (normwise or componentwise). See ERR_BNDS_NORM and +*> ERR_BNDS_COMP below. +*> \endverbatim +*> +*> \param[out] ERR_BNDS_NORM +*> \verbatim +*> ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> normwise relative error, which is defined as follows: +*> +*> Normwise relative error in the ith solution vector: +*> max_j (abs(XTRUE(j,i) - X(j,i))) +*> ------------------------------ +*> max_j abs(X(j,i)) +*> +*> The array is indexed by the type of error information as described +*> below. There currently are up to three pieces of information +*> returned. +*> +*> The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_NORM(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * dlamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * dlamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated normwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * dlamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*A, where S scales each row by a power of the +*> radix so all absolute row sums of Z are approximately 1. +*> +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[out] ERR_BNDS_COMP +*> \verbatim +*> ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> componentwise relative error, which is defined as follows: +*> +*> Componentwise relative error in the ith solution vector: +*> abs(XTRUE(j,i) - X(j,i)) +*> max_j ---------------------- +*> abs(X(j,i)) +*> +*> The array is indexed by the right-hand side i (on which the +*> componentwise relative error depends), and the type of error +*> information as described below. There currently are up to three +*> pieces of information returned for each right-hand side. If +*> componentwise accuracy is not requested (PARAMS(3) = 0.0), then +*> ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +*> the first (:,N_ERR_BNDS) entries are returned. +*> +*> The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_COMP(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * dlamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * dlamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated componentwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * dlamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*(A*diag(x)), where x is the solution for the +*> current right-hand side and S scales each row of +*> A*diag(x) by a power of the radix so all absolute row +*> sums of Z are approximately 1. +*> +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[in] NPARAMS +*> \verbatim +*> NPARAMS is INTEGER +*> Specifies the number of parameters set in PARAMS. If .LE. 0, the +*> PARAMS array is never referenced and default values are used. +*> \endverbatim +*> +*> \param[in,out] PARAMS +*> \verbatim +*> PARAMS is DOUBLE PRECISION array, dimension (NPARAMS) +*> Specifies algorithm parameters. If an entry is .LT. 0.0, then +*> that entry will be filled with default value used for that +*> parameter. Only positions up to NPARAMS are accessed; defaults +*> are used for higher-numbered parameters. +*> +*> PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +*> refinement or not. +*> Default: 1.0D+0 +*> = 0.0 : No refinement is performed, and no error bounds are +*> computed. +*> = 1.0 : Use the double-precision refinement algorithm, +*> possibly with doubled-single computations if the +*> compilation environment does not support DOUBLE +*> PRECISION. +*> (other values are reserved for future use) +*> +*> PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +*> computations allowed for refinement. +*> Default: 10 +*> Aggressive: Set to 100 to permit convergence using approximate +*> factorizations or factorizations other than LU. If +*> the factorization uses a technique other than +*> Gaussian elimination, the guarantees in +*> err_bnds_norm and err_bnds_comp may no longer be +*> trustworthy. +*> +*> PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +*> will attempt to find a solution with small componentwise +*> relative error in the double-precision algorithm. Positive +*> is true, 0.0 is false. +*> Default: 1.0 (attempt componentwise convergence) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Successful exit. The solution to every right-hand side is +*> guaranteed. +*> < 0: If INFO = -i, the i-th argument had an illegal value +*> > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +*> has been completed, but the factor U is exactly singular, so +*> the solution and error bounds could not be computed. RCOND = 0 +*> is returned. +*> = N+J: The solution corresponding to the Jth right-hand side is +*> not guaranteed. The solutions corresponding to other right- +*> hand sides K with K > J may not be guaranteed as well, but +*> only the first such right-hand side is reported. If a small +*> componentwise error is not requested (PARAMS(3) = 0.0) then +*> the Jth right-hand side is the first with a normwise error +*> bound that is not guaranteed (the smallest J such +*> that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +*> the Jth right-hand side is the first with either a normwise or +*> componentwise error bound that is not guaranteed (the smallest +*> J such that either ERR_BNDS_NORM(J,1) = 0.0 or +*> ERR_BNDS_COMP(J,1) = 0.0). See the definition of +*> ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +*> about all of the right-hand sides check ERR_BNDS_NORM or +*> ERR_BNDS_COMP. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doublePOcomputational +* +* ===================================================================== + SUBROUTINE DPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, + $ LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT + DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT + DOUBLE PRECISION DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0D+0 ) + PARAMETER ( ITHRESH_DEFAULT = 10.0D+0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0D+0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5D+0 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25D+0 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL RCEQU + INTEGER J, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + DOUBLE PRECISION ANORM, RCOND_TMP + DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DPOCON, DLA_PORFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, ILAPREC + EXTERNAL DLAMCH, DLANSY, DLA_PORCOND + DOUBLE PRECISION DLAMCH, DLANSY, DLA_PORCOND + LOGICAL LSAME + INTEGER ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0D+0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = DBLE( N ) * DLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0D+0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0D+0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0D+0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0D+0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0D+0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0D+0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + RCEQU = LSAME( EQUED, 'Y' ) +* +* Test input parameters. +* + IF (.NOT.LSAME(UPLO, 'U') .AND. .NOT.LSAME(UPLO, 'L')) THEN + INFO = -1 + ELSE IF( .NOT.RCEQU .AND. .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPORFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0D+0 + DO J = 1, NRHS + BERR( J ) = 0.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF + IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0D+0 + END IF + IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0D+0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0D+0 + DO J = 1, NRHS + BERR( J ) = 1.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF + IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + END IF + IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0D+0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + NORM = 'I' + ANORM = DLANSY( NORM, UPLO, N, A, LDA, WORK ) + CALL DPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, + $ IWORK, INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'E' ) + + CALL DLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, + $ NRHS, A, LDA, AF, LDAF, RCEQU, S, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ WORK( N+1 ), WORK( 1 ), WORK( 2*N+1 ), WORK( 1 ), RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + END IF + + ERR_LBND = MAX( 10.0D+0, SQRT( DBLE( N ) ) ) * DLAMCH( 'Epsilon' ) + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1 ) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( RCEQU ) THEN + RCOND_TMP = DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, + $ -1, S, INFO, WORK, IWORK ) + ELSE + RCOND_TMP = DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, + $ 0, S, INFO, WORK, IWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF (N_ERR_BNDS .GE. LA_LINRX_RCOND_I) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF + + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2 ) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( DLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF (ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, 1, + $ X( 1, J ), INFO, WORK, IWORK ) + ELSE + RCOND_TMP = 0.0D+0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0D+0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of DPORFSX +* + END diff --git a/math/lapack/src/main/fortran/dposv.f b/math/lapack/src/main/fortran/dposv.f new file mode 100644 index 0000000000..ab8f00775c --- /dev/null +++ b/math/lapack/src/main/fortran/dposv.f @@ -0,0 +1,193 @@ +*> \brief DPOSV computes the solution to system of linear equations A * X = B for PO matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPOSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPOSV computes the solution to a real system of linear equations +*> A * X = B, +*> where A is an N-by-N symmetric positive definite matrix and X and B +*> are N-by-NRHS matrices. +*> +*> The Cholesky decomposition is used to factor A as +*> A = U**T* U, if UPLO = 'U', or +*> A = L * L**T, if UPLO = 'L', +*> where U is an upper triangular matrix and L is a lower triangular +*> matrix. The factored form of A is then used to solve the system of +*> equations A * X = B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the factor U or L from the Cholesky +*> factorization A = U**T*U or A = L*L**T. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the leading minor of order i of A is not +*> positive definite, so the factorization could not be +*> completed, and the solution has not been computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePOsolve +* +* ===================================================================== + SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DPOTRF, DPOTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPOSV ', -INFO ) + RETURN + END IF +* +* Compute the Cholesky factorization A = U**T*U or A = L*L**T. +* + CALL DPOTRF( UPLO, N, A, LDA, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) +* + END IF + RETURN +* +* End of DPOSV +* + END diff --git a/math/lapack/src/main/fortran/dposvx.f b/math/lapack/src/main/fortran/dposvx.f new file mode 100644 index 0000000000..cf33c96a31 --- /dev/null +++ b/math/lapack/src/main/fortran/dposvx.f @@ -0,0 +1,494 @@ +*> \brief DPOSVX computes the solution to system of linear equations A * X = B for PO matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPOSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, +* S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, +* IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER EQUED, FACT, UPLO +* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), +* $ BERR( * ), FERR( * ), S( * ), WORK( * ), +* $ X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to +*> compute the solution to a real system of linear equations +*> A * X = B, +*> where A is an N-by-N symmetric positive definite matrix and X and B +*> are N-by-NRHS matrices. +*> +*> Error bounds on the solution and a condition estimate are also +*> provided. +*> \endverbatim +* +*> \par Description: +* ================= +*> +*> \verbatim +*> +*> The following steps are performed: +*> +*> 1. If FACT = 'E', real scaling factors are computed to equilibrate +*> the system: +*> diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B +*> Whether or not the system will be equilibrated depends on the +*> scaling of the matrix A, but if equilibration is used, A is +*> overwritten by diag(S)*A*diag(S) and B by diag(S)*B. +*> +*> 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to +*> factor the matrix A (after equilibration if FACT = 'E') as +*> A = U**T* U, if UPLO = 'U', or +*> A = L * L**T, if UPLO = 'L', +*> where U is an upper triangular matrix and L is a lower triangular +*> matrix. +*> +*> 3. If the leading i-by-i principal minor is not positive definite, +*> then the routine returns with INFO = i. Otherwise, the factored +*> form of A is used to estimate the condition number of the matrix +*> A. If the reciprocal of the condition number is less than machine +*> precision, INFO = N+1 is returned as a warning, but the routine +*> still goes on to solve for X and compute error bounds as +*> described below. +*> +*> 4. The system of equations is solved for X using the factored form +*> of A. +*> +*> 5. Iterative refinement is applied to improve the computed solution +*> matrix and calculate error bounds and backward error estimates +*> for it. +*> +*> 6. If equilibration was used, the matrix X is premultiplied by +*> diag(S) so that it solves the original system before +*> equilibration. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> Specifies whether or not the factored form of the matrix A is +*> supplied on entry, and if not, whether the matrix A should be +*> equilibrated before it is factored. +*> = 'F': On entry, AF contains the factored form of A. +*> If EQUED = 'Y', the matrix A has been equilibrated +*> with scaling factors given by S. A and AF will not +*> be modified. +*> = 'N': The matrix A will be copied to AF and factored. +*> = 'E': The matrix A will be equilibrated if necessary, then +*> copied to AF and factored. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A, except if FACT = 'F' and +*> EQUED = 'Y', then A must contain the equilibrated matrix +*> diag(S)*A*diag(S). If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. A is not modified if +*> FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. +*> +*> On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by +*> diag(S)*A*diag(S). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> If FACT = 'F', then AF is an input argument and on entry +*> contains the triangular factor U or L from the Cholesky +*> factorization A = U**T*U or A = L*L**T, in the same storage +*> format as A. If EQUED .ne. 'N', then AF is the factored form +*> of the equilibrated matrix diag(S)*A*diag(S). +*> +*> If FACT = 'N', then AF is an output argument and on exit +*> returns the triangular factor U or L from the Cholesky +*> factorization A = U**T*U or A = L*L**T of the original +*> matrix A. +*> +*> If FACT = 'E', then AF is an output argument and on exit +*> returns the triangular factor U or L from the Cholesky +*> factorization A = U**T*U or A = L*L**T of the equilibrated +*> matrix A (see the description of A for the form of the +*> equilibrated matrix). +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] EQUED +*> \verbatim +*> EQUED is CHARACTER*1 +*> Specifies the form of equilibration that was done. +*> = 'N': No equilibration (always true if FACT = 'N'). +*> = 'Y': Equilibration was done, i.e., A has been replaced by +*> diag(S) * A * diag(S). +*> EQUED is an input argument if FACT = 'F'; otherwise, it is an +*> output argument. +*> \endverbatim +*> +*> \param[in,out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N) +*> The scale factors for A; not accessed if EQUED = 'N'. S is +*> an input argument if FACT = 'F'; otherwise, S is an output +*> argument. If FACT = 'F' and EQUED = 'Y', each element of S +*> must be positive. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', +*> B is overwritten by diag(S) * B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to +*> the original system of equations. Note that if EQUED = 'Y', +*> A and B are modified on exit, and the solution to the +*> equilibrated system is inv(diag(S))*X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is 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. +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, and i is +*> <= N: the leading minor of order i of A is +*> not positive definite, so the factorization +*> could not be completed, and the solution has not +*> been computed. RCOND = 0 is returned. +*> = N+1: U is nonsingular, but RCOND is less than machine +*> precision, meaning that the matrix is singular +*> to working precision. Nevertheless, the +*> solution and error bounds are computed because +*> there are a number of situations where the +*> computed solution can be more accurate than the +*> value of RCOND would suggest. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doublePOsolve +* +* ===================================================================== + SUBROUTINE DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, + $ S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, + $ IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, UPLO + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ BERR( * ), FERR( * ), S( * ), WORK( * ), + $ X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, RCEQU + INTEGER I, INFEQU, J + DOUBLE PRECISION AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DLAQSY, DPOCON, DPOEQU, DPORFS, DPOTRF, + $ DPOTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + RCEQU = .FALSE. + ELSE + RCEQU = LSAME( EQUED, 'Y' ) + 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.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) + $ THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -9 + ELSE + IF( RCEQU ) THEN + SMIN = BIGNUM + SMAX = ZERO + DO 10 J = 1, N + SMIN = MIN( SMIN, S( J ) ) + SMAX = MAX( SMAX, S( J ) ) + 10 CONTINUE + IF( SMIN.LE.ZERO ) THEN + INFO = -10 + ELSE IF( N.GT.0 ) THEN + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + ELSE + SCOND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPOSVX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL DPOEQU( N, A, LDA, S, SCOND, AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) + RCEQU = LSAME( EQUED, 'Y' ) + END IF + END IF +* +* Scale the right hand side. +* + IF( RCEQU ) THEN + DO 30 J = 1, NRHS + DO 20 I = 1, N + B( I, J ) = S( I )*B( I, J ) + 20 CONTINUE + 30 CONTINUE + END IF +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the Cholesky factorization A = U**T *U or A = L*L**T. +* + CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF ) + CALL DPOTRF( UPLO, N, AF, LDAF, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 )THEN + RCOND = ZERO + RETURN + END IF + END IF +* +* Compute the norm of the matrix A. +* + ANORM = DLANSY( '1', UPLO, N, A, LDA, WORK ) +* +* Compute the reciprocal of the condition number of A. +* + CALL DPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO ) +* +* Compute the solution matrix X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, + $ FERR, BERR, WORK, IWORK, INFO ) +* +* Transform the solution matrix X to a solution of the original +* system. +* + IF( RCEQU ) THEN + DO 50 J = 1, NRHS + DO 40 I = 1, N + X( I, J ) = S( I )*X( I, J ) + 40 CONTINUE + 50 CONTINUE + DO 60 J = 1, NRHS + FERR( J ) = FERR( J ) / SCOND + 60 CONTINUE + END IF +* +* Set INFO = N+1 if the matrix is singular to working precision. +* + IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) + $ INFO = N + 1 +* + RETURN +* +* End of DPOSVX +* + END diff --git a/math/lapack/src/main/fortran/dposvxx.f b/math/lapack/src/main/fortran/dposvxx.f new file mode 100644 index 0000000000..488e0b15af --- /dev/null +++ b/math/lapack/src/main/fortran/dposvxx.f @@ -0,0 +1,683 @@ +*> \brief DPOSVXX computes the solution to system of linear equations A * X = B for PO matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPOSVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, +* S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, +* N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, +* NPARAMS, PARAMS, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER EQUED, FACT, UPLO +* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, +* $ N_ERR_BNDS +* DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), +* $ X( LDX, * ), WORK( * ) +* DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), +* $ ERR_BNDS_NORM( NRHS, * ), +* $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T +*> to compute the solution to a double precision system of linear equations +*> A * X = B, where A is an N-by-N symmetric positive definite matrix +*> and X and B are N-by-NRHS matrices. +*> +*> If requested, both normwise and maximum componentwise error bounds +*> are returned. DPOSVXX will return a solution with a tiny +*> guaranteed error (O(eps) where eps is the working machine +*> precision) unless the matrix is very ill-conditioned, in which +*> case a warning is returned. Relevant condition numbers also are +*> calculated and returned. +*> +*> DPOSVXX accepts user-provided factorizations and equilibration +*> factors; see the definitions of the FACT and EQUED options. +*> Solving with refinement and using a factorization from a previous +*> DPOSVXX call will also produce a solution with either O(eps) +*> errors or warnings, but we cannot make that claim for general +*> user-provided factorizations and equilibration factors if they +*> differ from what DPOSVXX would itself produce. +*> \endverbatim +* +*> \par Description: +* ================= +*> +*> \verbatim +*> +*> The following steps are performed: +*> +*> 1. If FACT = 'E', double precision scaling factors are computed to equilibrate +*> the system: +*> +*> diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B +*> +*> Whether or not the system will be equilibrated depends on the +*> scaling of the matrix A, but if equilibration is used, A is +*> overwritten by diag(S)*A*diag(S) and B by diag(S)*B. +*> +*> 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to +*> factor the matrix A (after equilibration if FACT = 'E') as +*> A = U**T* U, if UPLO = 'U', or +*> A = L * L**T, if UPLO = 'L', +*> where U is an upper triangular matrix and L is a lower triangular +*> matrix. +*> +*> 3. If the leading i-by-i principal minor is not positive definite, +*> then the routine returns with INFO = i. Otherwise, the factored +*> form of A is used to estimate the condition number of the matrix +*> A (see argument RCOND). If the reciprocal of the condition number +*> is less than machine precision, the routine still goes on to solve +*> for X and compute error bounds as described below. +*> +*> 4. The system of equations is solved for X using the factored form +*> of A. +*> +*> 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +*> the routine will use iterative refinement to try to get a small +*> error and error bounds. Refinement calculates the residual to at +*> least twice the working precision. +*> +*> 6. If equilibration was used, the matrix X is premultiplied by +*> diag(S) so that it solves the original system before +*> equilibration. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> Some optional parameters are bundled in the PARAMS array. These +*> settings determine how refinement is performed, but often the +*> defaults are acceptable. If the defaults are acceptable, users +*> can pass NPARAMS = 0 which prevents the source code from accessing +*> the PARAMS argument. +*> \endverbatim +*> +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> Specifies whether or not the factored form of the matrix A is +*> supplied on entry, and if not, whether the matrix A should be +*> equilibrated before it is factored. +*> = 'F': On entry, AF contains the factored form of A. +*> If EQUED is not 'N', the matrix A has been +*> equilibrated with scaling factors given by S. +*> A and AF are not modified. +*> = 'N': The matrix A will be copied to AF and factored. +*> = 'E': The matrix A will be equilibrated if necessary, then +*> copied to AF and factored. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A, except if FACT = 'F' and EQUED = +*> 'Y', then A must contain the equilibrated matrix +*> diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper +*> triangular part of A contains the upper triangular part of the +*> matrix A, and the strictly lower triangular part of A is not +*> referenced. If UPLO = 'L', the leading N-by-N lower triangular +*> part of A contains the lower triangular part of the matrix A, and +*> the strictly upper triangular part of A is not referenced. A is +*> not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED = +*> 'N' on exit. +*> +*> On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by +*> diag(S)*A*diag(S). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> If FACT = 'F', then AF is an input argument and on entry +*> contains the triangular factor U or L from the Cholesky +*> factorization A = U**T*U or A = L*L**T, in the same storage +*> format as A. If EQUED .ne. 'N', then AF is the factored +*> form of the equilibrated matrix diag(S)*A*diag(S). +*> +*> If FACT = 'N', then AF is an output argument and on exit +*> returns the triangular factor U or L from the Cholesky +*> factorization A = U**T*U or A = L*L**T of the original +*> matrix A. +*> +*> If FACT = 'E', then AF is an output argument and on exit +*> returns the triangular factor U or L from the Cholesky +*> factorization A = U**T*U or A = L*L**T of the equilibrated +*> matrix A (see the description of A for the form of the +*> equilibrated matrix). +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] EQUED +*> \verbatim +*> EQUED is CHARACTER*1 +*> Specifies the form of equilibration that was done. +*> = 'N': No equilibration (always true if FACT = 'N'). +*> = 'Y': Both row and column equilibration, i.e., A has been +*> replaced by diag(S) * A * diag(S). +*> EQUED is an input argument if FACT = 'F'; otherwise, it is an +*> output argument. +*> \endverbatim +*> +*> \param[in,out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N) +*> The row scale factors for A. If EQUED = 'Y', A is multiplied on +*> the left and right by diag(S). S is an input argument if FACT = +*> 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +*> = 'Y', each element of S must be positive. If S is output, each +*> element of S is a power of the radix. If S is input, each element +*> of S should be a power of the radix to ensure a reliable solution +*> and error estimates. Scaling by powers of the radix does not cause +*> rounding errors unless the result underflows or overflows. +*> Rounding errors during scaling lead to refining with a matrix that +*> is not equivalent to the input matrix, producing error estimates +*> that may not be reliable. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, +*> if EQUED = 'N', B is not modified; +*> if EQUED = 'Y', B is overwritten by diag(S)*B; +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> If INFO = 0, the N-by-NRHS solution matrix X to the original +*> system of equations. Note that A and B are modified on exit if +*> EQUED .ne. 'N', and the solution to the equilibrated system is +*> inv(diag(S))*X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> Reciprocal scaled condition number. This is an estimate of the +*> reciprocal Skeel condition number of the matrix A after +*> equilibration (if done). If this is less than the machine +*> precision (in particular, if it is zero), the matrix is singular +*> to working precision. Note that the error may still be small even +*> if this number is very small and the matrix appears ill- +*> conditioned. +*> \endverbatim +*> +*> \param[out] RPVGRW +*> \verbatim +*> RPVGRW is DOUBLE PRECISION +*> Reciprocal pivot growth. On exit, this contains the reciprocal +*> pivot growth factor norm(A)/norm(U). The "max absolute element" +*> norm is used. If this is much less than 1, then the stability of +*> the LU factorization of the (equilibrated) matrix A could be poor. +*> This also means that the solution X, estimated condition numbers, +*> and error bounds could be unreliable. If factorization fails with +*> 0 for the leading INFO columns of A. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is DOUBLE PRECISION array, dimension (NRHS) +*> Componentwise relative backward error. This is the +*> componentwise relative backward error of each solution vector X(j) +*> (i.e., the smallest relative change in any element of A or B that +*> makes X(j) an exact solution). +*> \endverbatim +*> +*> \param[in] N_ERR_BNDS +*> \verbatim +*> N_ERR_BNDS is INTEGER +*> Number of error bounds to return for each right hand side +*> and each type (normwise or componentwise). See ERR_BNDS_NORM and +*> ERR_BNDS_COMP below. +*> \endverbatim +*> +*> \param[out] ERR_BNDS_NORM +*> \verbatim +*> ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> normwise relative error, which is defined as follows: +*> +*> Normwise relative error in the ith solution vector: +*> max_j (abs(XTRUE(j,i) - X(j,i))) +*> ------------------------------ +*> max_j abs(X(j,i)) +*> +*> The array is indexed by the type of error information as described +*> below. There currently are up to three pieces of information +*> returned. +*> +*> The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_NORM(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * dlamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * dlamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated normwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * dlamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*A, where S scales each row by a power of the +*> radix so all absolute row sums of Z are approximately 1. +*> +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[out] ERR_BNDS_COMP +*> \verbatim +*> ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> componentwise relative error, which is defined as follows: +*> +*> Componentwise relative error in the ith solution vector: +*> abs(XTRUE(j,i) - X(j,i)) +*> max_j ---------------------- +*> abs(X(j,i)) +*> +*> The array is indexed by the right-hand side i (on which the +*> componentwise relative error depends), and the type of error +*> information as described below. There currently are up to three +*> pieces of information returned for each right-hand side. If +*> componentwise accuracy is not requested (PARAMS(3) = 0.0), then +*> ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +*> the first (:,N_ERR_BNDS) entries are returned. +*> +*> The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_COMP(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * dlamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * dlamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated componentwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * dlamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*(A*diag(x)), where x is the solution for the +*> current right-hand side and S scales each row of +*> A*diag(x) by a power of the radix so all absolute row +*> sums of Z are approximately 1. +*> +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[in] NPARAMS +*> \verbatim +*> NPARAMS is INTEGER +*> Specifies the number of parameters set in PARAMS. If .LE. 0, the +*> PARAMS array is never referenced and default values are used. +*> \endverbatim +*> +*> \param[in,out] PARAMS +*> \verbatim +*> PARAMS is DOUBLE PRECISION array, dimension NPARAMS +*> Specifies algorithm parameters. If an entry is .LT. 0.0, then +*> that entry will be filled with default value used for that +*> parameter. Only positions up to NPARAMS are accessed; defaults +*> are used for higher-numbered parameters. +*> +*> PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +*> refinement or not. +*> Default: 1.0D+0 +*> = 0.0 : No refinement is performed, and no error bounds are +*> computed. +*> = 1.0 : Use the extra-precise refinement algorithm. +*> (other values are reserved for future use) +*> +*> PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +*> computations allowed for refinement. +*> Default: 10 +*> Aggressive: Set to 100 to permit convergence using approximate +*> factorizations or factorizations other than LU. If +*> the factorization uses a technique other than +*> Gaussian elimination, the guarantees in +*> err_bnds_norm and err_bnds_comp may no longer be +*> trustworthy. +*> +*> PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +*> will attempt to find a solution with small componentwise +*> relative error in the double-precision algorithm. Positive +*> is true, 0.0 is false. +*> Default: 1.0 (attempt componentwise convergence) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Successful exit. The solution to every right-hand side is +*> guaranteed. +*> < 0: If INFO = -i, the i-th argument had an illegal value +*> > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +*> has been completed, but the factor U is exactly singular, so +*> the solution and error bounds could not be computed. RCOND = 0 +*> is returned. +*> = N+J: The solution corresponding to the Jth right-hand side is +*> not guaranteed. The solutions corresponding to other right- +*> hand sides K with K > J may not be guaranteed as well, but +*> only the first such right-hand side is reported. If a small +*> componentwise error is not requested (PARAMS(3) = 0.0) then +*> the Jth right-hand side is the first with a normwise error +*> bound that is not guaranteed (the smallest J such +*> that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +*> the Jth right-hand side is the first with either a normwise or +*> componentwise error bound that is not guaranteed (the smallest +*> J such that either ERR_BNDS_NORM(J,1) = 0.0 or +*> ERR_BNDS_COMP(J,1) = 0.0). See the definition of +*> ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +*> about all of the right-hand sides check ERR_BNDS_NORM or +*> ERR_BNDS_COMP. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doublePOsolve +* +* ===================================================================== + SUBROUTINE DPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, + $ S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ NPARAMS, PARAMS, WORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, UPLO + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, RCEQU + INTEGER INFEQU, J + DOUBLE PRECISION AMAX, BIGNUM, SMIN, SMAX, + $ SCOND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, DLAMCH, DLA_PORPVGRW + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLA_PORPVGRW +* .. +* .. External Subroutines .. + EXTERNAL DPOEQUB, DPOTRF, DPOTRS, DLACPY, DLAQSY, + $ XERBLA, DLASCL2, DPORFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + RCEQU = .FALSE. + ELSE + RCEQU = LSAME( EQUED, 'Y' ) + ENDIF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in DPORFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until DPORFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. + $ .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -9 + ELSE + IF ( RCEQU ) THEN + SMIN = BIGNUM + SMAX = ZERO + DO 10 J = 1, N + SMIN = MIN( SMIN, S( J ) ) + SMAX = MAX( SMAX, S( J ) ) + 10 CONTINUE + IF( SMIN.LE.ZERO ) THEN + INFO = -10 + ELSE IF( N.GT.0 ) THEN + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + ELSE + SCOND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPOSVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL DPOEQUB( N, A, LDA, S, SCOND, AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) + RCEQU = LSAME( EQUED, 'Y' ) + END IF + END IF +* +* Scale the right-hand side. +* + IF( RCEQU ) CALL DLASCL2( N, NRHS, S, B, LDB ) +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the Cholesky factorization of A. +* + CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF ) + CALL DPOTRF( UPLO, N, AF, LDAF, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.NE.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + RPVGRW = DLA_PORPVGRW( UPLO, INFO, A, LDA, AF, LDAF, WORK ) + RETURN + ENDIF + END IF +* +* Compute the reciprocal growth factor RPVGRW. +* + RPVGRW = DLA_PORPVGRW( UPLO, N, A, LDA, AF, LDAF, WORK ) +* +* Compute the solution matrix X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL DPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO ) + +* +* Scale solutions. +* + IF ( RCEQU ) THEN + CALL DLASCL2 ( N, NRHS, S, X, LDX ) + END IF +* + RETURN +* +* End of DPOSVXX +* + END diff --git a/math/lapack/src/main/fortran/dpotf2.f b/math/lapack/src/main/fortran/dpotf2.f new file mode 100644 index 0000000000..1fb60a903b --- /dev/null +++ b/math/lapack/src/main/fortran/dpotf2.f @@ -0,0 +1,230 @@ +*> \brief \b DPOTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite matrix (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPOTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPOTF2 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 unblocked version of the algorithm, calling Level 2 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n by n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n by n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the factor U or L from the Cholesky +*> factorization A = U**T *U or A = L*L**T. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> > 0: if INFO = k, the leading minor of order k is not +*> positive definite, and the factorization could not be +*> completed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePOcomputational +* +* ===================================================================== + SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. 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, DISNAN + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT, DISNAN +* .. +* .. 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**T *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.OR.DISNAN( AJJ ) ) 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**T. +* + 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.OR.DISNAN( AJJ ) ) 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/math/lapack/src/main/fortran/dpotrf.f b/math/lapack/src/main/fortran/dpotrf.f new file mode 100644 index 0000000000..1fa75a4654 --- /dev/null +++ b/math/lapack/src/main/fortran/dpotrf.f @@ -0,0 +1,246 @@ +*> \brief \b DPOTRF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPOTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the leading minor of order i is not +*> positive definite, and the factorization could not be +*> completed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePOcomputational +* +* ===================================================================== + SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. 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, DPOTRF2, 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 DPOTRF2( UPLO, N, A, LDA, INFO ) + ELSE +* +* Use blocked code. +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization A = U**T*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 DPOTRF2( '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**T. +* + 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 DPOTRF2( '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/math/lapack/src/main/fortran/dpotrf2.f b/math/lapack/src/main/fortran/dpotrf2.f new file mode 100644 index 0000000000..0d419c4f00 --- /dev/null +++ b/math/lapack/src/main/fortran/dpotrf2.f @@ -0,0 +1,237 @@ +*> \brief \b DPOTRF2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPOTRF2 computes the Cholesky factorization of a real symmetric +*> positive definite matrix A using the recursive algorithm. +*> +*> 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 recursive version of the algorithm. It divides +*> the matrix into four submatrices: +*> +*> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 +*> A = [ -----|----- ] with n1 = n/2 +*> [ A21 | A22 ] n2 = n-n1 +*> +*> The subroutine calls itself to factor A11. Update and scale A21 +*> or A12, update A22 then calls itself to factor A22. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the leading minor of order i is not +*> positive definite, and the factorization could not be +*> completed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePOcomputational +* +* ===================================================================== + RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER N1, N2, IINFO +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + EXTERNAL LSAME, DISNAN +* .. +* .. External Subroutines .. + EXTERNAL DSYRK, DTRSM, 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( 'DPOTRF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* N=1 case +* + IF( N.EQ.1 ) THEN +* +* Test for non-positive-definiteness +* + IF( A( 1, 1 ).LE.ZERO.OR.DISNAN( A( 1, 1 ) ) ) THEN + INFO = 1 + RETURN + END IF +* +* Factor +* + A( 1, 1 ) = SQRT( A( 1, 1 ) ) +* +* Use recursive code +* + ELSE + N1 = N/2 + N2 = N-N1 +* +* Factor A11 +* + CALL DPOTRF2( UPLO, N1, A( 1, 1 ), LDA, IINFO ) + IF ( IINFO.NE.0 ) THEN + INFO = IINFO + RETURN + END IF +* +* Compute the Cholesky factorization A = U**T*U +* + IF( UPPER ) THEN +* +* Update and scale A12 +* + CALL DTRSM( 'L', 'U', 'T', 'N', N1, N2, ONE, + $ A( 1, 1 ), LDA, A( 1, N1+1 ), LDA ) +* +* Update and factor A22 +* + CALL DSYRK( UPLO, 'T', N2, N1, -ONE, A( 1, N1+1 ), LDA, + $ ONE, A( N1+1, N1+1 ), LDA ) + CALL DPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) + IF ( IINFO.NE.0 ) THEN + INFO = IINFO + N1 + RETURN + END IF +* +* Compute the Cholesky factorization A = L*L**T +* + ELSE +* +* Update and scale A21 +* + CALL DTRSM( 'R', 'L', 'T', 'N', N2, N1, ONE, + $ A( 1, 1 ), LDA, A( N1+1, 1 ), LDA ) +* +* Update and factor A22 +* + CALL DSYRK( UPLO, 'N', N2, N1, -ONE, A( N1+1, 1 ), LDA, + $ ONE, A( N1+1, N1+1 ), LDA ) + CALL DPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) + IF ( IINFO.NE.0 ) THEN + INFO = IINFO + N1 + RETURN + END IF + END IF + END IF + RETURN +* +* End of DPOTRF2 +* + END diff --git a/math/lapack/src/main/fortran/dpotri.f b/math/lapack/src/main/fortran/dpotri.f new file mode 100644 index 0000000000..4d2dcb43ba --- /dev/null +++ b/math/lapack/src/main/fortran/dpotri.f @@ -0,0 +1,159 @@ +*> \brief \b DPOTRI +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPOTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPOTRI computes the inverse of a real symmetric positive definite +*> matrix A using the Cholesky factorization A = U**T*U or A = L*L**T +*> computed by DPOTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the triangular factor U or L from the Cholesky +*> factorization A = U**T*U or A = L*L**T, as computed by +*> DPOTRF. +*> On exit, the upper or lower triangle of the (symmetric) +*> inverse of A, overwriting the input factor U or L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the (i,i) element of the factor U or L is +*> zero, and the inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePOcomputational +* +* ===================================================================== + SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLAUUM, DTRTRI, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( .NOT.LSAME( UPLO, 'U' ) .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( 'DPOTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Invert the triangular Cholesky factor U or L. +* + CALL DTRTRI( UPLO, 'Non-unit', N, A, LDA, INFO ) + IF( INFO.GT.0 ) + $ RETURN +* +* Form inv(U) * inv(U)**T or inv(L)**T * inv(L). +* + CALL DLAUUM( UPLO, N, A, LDA, INFO ) +* + RETURN +* +* End of DPOTRI +* + END diff --git a/math/lapack/src/main/fortran/dpotrs.f b/math/lapack/src/main/fortran/dpotrs.f new file mode 100644 index 0000000000..4cc5e74f3d --- /dev/null +++ b/math/lapack/src/main/fortran/dpotrs.f @@ -0,0 +1,204 @@ +*> \brief \b DPOTRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPOTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The triangular factor U or L from the Cholesky factorization +*> A = U**T*U or A = L*L**T, as computed by DPOTRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePOcomputational +* +* ===================================================================== + SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. 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**T *U. +* +* Solve U**T *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**T. +* +* 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**T *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/math/lapack/src/main/fortran/dppcon.f b/math/lapack/src/main/fortran/dppcon.f new file mode 100644 index 0000000000..0e6ab922e1 --- /dev/null +++ b/math/lapack/src/main/fortran/dppcon.f @@ -0,0 +1,248 @@ +*> \brief \b DPPCON +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION AP( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPPCON estimates the reciprocal of the condition number (in the +*> 1-norm) of a real symmetric positive definite packed matrix using +*> the Cholesky factorization A = U**T*U or A = L*L**T computed by +*> DPPTRF. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> The triangular factor U or L from the Cholesky factorization +*> A = U**T*U or A = L*L**T, packed columnwise in a linear +*> array. The j-th column of U or L is stored in the array AP +*> as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is DOUBLE PRECISION +*> The 1-norm (or infinity-norm) of the symmetric matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AP( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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, DLATPS, DRSCL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. 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( ANORM.LT.ZERO ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPPCON', -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 the inverse. +* + 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**T). +* + CALL DLATPS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, + $ AP, WORK, SCALEL, WORK( 2*N+1 ), INFO ) + NORMIN = 'Y' +* +* Multiply by inv(U). +* + CALL DLATPS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, + $ AP, WORK, SCALEU, WORK( 2*N+1 ), INFO ) + ELSE +* +* Multiply by inv(L). +* + CALL DLATPS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N, + $ AP, WORK, SCALEL, WORK( 2*N+1 ), INFO ) + NORMIN = 'Y' +* +* Multiply by inv(L**T). +* + CALL DLATPS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N, + $ AP, 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 DPPCON +* + END diff --git a/math/lapack/src/main/fortran/dppequ.f b/math/lapack/src/main/fortran/dppequ.f new file mode 100644 index 0000000000..3563b59d10 --- /dev/null +++ b/math/lapack/src/main/fortran/dppequ.f @@ -0,0 +1,238 @@ +*> \brief \b DPPEQU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPPEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, N +* DOUBLE PRECISION AMAX, SCOND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ), S( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPPEQU computes row and column scalings intended to equilibrate a +*> symmetric positive definite matrix A in packed storage and reduce +*> its condition number (with respect to the two-norm). S contains the +*> scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix +*> B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. +*> This choice of S puts the condition number of B within a factor N of +*> the smallest possible condition number over all possible diagonal +*> scalings. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is 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. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, S contains the scale factors for A. +*> \endverbatim +*> +*> \param[out] SCOND +*> \verbatim +*> SCOND is DOUBLE PRECISION +*> If INFO = 0, S contains the ratio of the smallest S(i) to +*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too +*> large nor too small, it is not worth scaling by S. +*> \endverbatim +*> +*> \param[out] AMAX +*> \verbatim +*> AMAX is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the i-th diagonal element is nonpositive. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, N + DOUBLE PRECISION AMAX, SCOND +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), S( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, JJ + DOUBLE PRECISION SMIN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, 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( 'DPPEQU', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + SCOND = ONE + AMAX = ZERO + RETURN + END IF +* +* Initialize SMIN and AMAX. +* + S( 1 ) = AP( 1 ) + SMIN = S( 1 ) + AMAX = S( 1 ) +* + IF( UPPER ) THEN +* +* UPLO = 'U': Upper triangle of A is stored. +* Find the minimum and maximum diagonal elements. +* + JJ = 1 + DO 10 I = 2, N + JJ = JJ + I + S( I ) = AP( JJ ) + SMIN = MIN( SMIN, S( I ) ) + AMAX = MAX( AMAX, S( I ) ) + 10 CONTINUE +* + ELSE +* +* UPLO = 'L': Lower triangle of A is stored. +* Find the minimum and maximum diagonal elements. +* + JJ = 1 + DO 20 I = 2, N + JJ = JJ + N - I + 2 + S( I ) = AP( JJ ) + SMIN = MIN( SMIN, S( I ) ) + AMAX = MAX( AMAX, S( I ) ) + 20 CONTINUE + END IF +* + IF( SMIN.LE.ZERO ) THEN +* +* Find the first non-positive diagonal element and return. +* + DO 30 I = 1, N + IF( S( I ).LE.ZERO ) THEN + INFO = I + RETURN + END IF + 30 CONTINUE + ELSE +* +* Set the scale factors to the reciprocals +* of the diagonal elements. +* + DO 40 I = 1, N + S( I ) = ONE / SQRT( S( I ) ) + 40 CONTINUE +* +* Compute SCOND = min(S(I)) / max(S(I)) +* + SCOND = SQRT( SMIN ) / SQRT( AMAX ) + END IF + RETURN +* +* End of DPPEQU +* + END diff --git a/math/lapack/src/main/fortran/dpprfs.f b/math/lapack/src/main/fortran/dpprfs.f new file mode 100644 index 0000000000..1c068e21c2 --- /dev/null +++ b/math/lapack/src/main/fortran/dpprfs.f @@ -0,0 +1,421 @@ +*> \brief \b DPPRFS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, +* BERR, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), +* $ FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPPRFS improves the computed solution to a system of linear +*> equations when the coefficient matrix is symmetric positive definite +*> and packed, and provides error bounds and backward error estimates +*> for the solution. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is 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. +*> \endverbatim +*> +*> \param[in] AFP +*> \verbatim +*> AFP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> The triangular factor U or L from the Cholesky factorization +*> A = U**T*U or A = L*L**T, as computed by DPPTRF/ZPPTRF, +*> packed columnwise in a linear array in the same format as A +*> (see AP). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> On entry, the solution matrix X, as computed by DPPTRS. +*> On exit, the improved solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> ITMAX is the maximum number of steps of iterative refinement. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, + $ BERR, WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), + $ FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. 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 UPPER + INTEGER COUNT, I, IK, J, K, KASE, KK, NZ + DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLACN2, DPPTRS, DSPMV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. 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( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPPRFS', -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 +* +* 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 - A * X +* + CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) + CALL DSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ), + $ 1 ) +* +* Compute componentwise relative backward error from formula +* +* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) +* +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. If the i-th component of the denominator is less +* than SAFE2, then SAFE1 is added to the i-th components of the +* numerator and denominator before dividing. +* + DO 30 I = 1, N + WORK( I ) = ABS( B( I, J ) ) + 30 CONTINUE +* +* Compute abs(A)*abs(X) + abs(B). +* + KK = 1 + IF( UPPER ) THEN + DO 50 K = 1, N + S = ZERO + XK = ABS( X( K, J ) ) + IK = KK + DO 40 I = 1, K - 1 + WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK + S = S + ABS( AP( IK ) )*ABS( X( I, J ) ) + IK = IK + 1 + 40 CONTINUE + WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S + KK = KK + K + 50 CONTINUE + ELSE + DO 70 K = 1, N + S = ZERO + XK = ABS( X( K, J ) ) + WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK + IK = KK + 1 + DO 60 I = K + 1, N + WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK + S = S + ABS( AP( IK ) )*ABS( X( I, J ) ) + IK = IK + 1 + 60 CONTINUE + WORK( K ) = WORK( K ) + S + KK = KK + ( N-K+1 ) + 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 DPPTRS( UPLO, N, 1, AFP, 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(A))* +* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) +* +* where +* norm(Z) is the magnitude of the largest component of Z +* inv(A) is the inverse of A +* abs(Z) is the componentwise absolute value of the matrix or +* vector Z +* NZ is the maximum number of nonzeros in any row of A, plus 1 +* EPS is machine epsilon +* +* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) +* is incremented by SAFE1 if the i-th component of +* abs(A)*abs(X) + abs(B) is less than SAFE2. +* +* Use DLACN2 to estimate the infinity-norm of the matrix +* inv(A) * diag(W), +* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) +* + 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(A**T). +* + CALL DPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO ) + DO 110 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 110 CONTINUE + ELSE IF( KASE.EQ.2 ) THEN +* +* Multiply by inv(A)*diag(W). +* + DO 120 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 120 CONTINUE + CALL DPPTRS( UPLO, N, 1, AFP, 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 DPPRFS +* + END diff --git a/math/lapack/src/main/fortran/dppsv.f b/math/lapack/src/main/fortran/dppsv.f new file mode 100644 index 0000000000..cb70bab434 --- /dev/null +++ b/math/lapack/src/main/fortran/dppsv.f @@ -0,0 +1,205 @@ +*> \brief DPPSV computes the solution to system of linear equations A * X = B for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPPSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPPSV computes the solution to a real system of linear equations +*> A * X = B, +*> where A is an N-by-N symmetric positive definite matrix stored in +*> packed format and X and B are N-by-NRHS matrices. +*> +*> The Cholesky decomposition is used to factor A as +*> A = U**T* U, if UPLO = 'U', or +*> A = L * L**T, if UPLO = 'L', +*> where U is an upper triangular matrix and L is a lower triangular +*> matrix. The factored form of A is then used to solve the system of +*> equations A * X = B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> On entry, the upper or lower triangle of the symmetric matrix +*> A, packed columnwise in a linear array. The j-th column of A +*> is stored in the array AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +*> See below for further details. +*> +*> On exit, if INFO = 0, the factor U or L from the Cholesky +*> factorization A = U**T*U or A = L*L**T, in the same storage +*> format as A. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the leading minor of order i of A is not +*> positive definite, so the factorization could not be +*> completed, and the solution has not been computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERsolve +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The packed storage scheme is illustrated by the following example +*> when N = 4, UPLO = 'U': +*> +*> Two-dimensional storage of the symmetric matrix A: +*> +*> a11 a12 a13 a14 +*> a22 a23 a24 +*> a33 a34 (aij = conjg(aji)) +*> a44 +*> +*> Packed storage of the upper triangle of A: +*> +*> AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DPPTRF, DPPTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + 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( LDB.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPPSV ', -INFO ) + RETURN + END IF +* +* Compute the Cholesky factorization A = U**T*U or A = L*L**T. +* + CALL DPPTRF( UPLO, N, AP, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) +* + END IF + RETURN +* +* End of DPPSV +* + END diff --git a/math/lapack/src/main/fortran/dppsvx.f b/math/lapack/src/main/fortran/dppsvx.f new file mode 100644 index 0000000000..df949896e2 --- /dev/null +++ b/math/lapack/src/main/fortran/dppsvx.f @@ -0,0 +1,494 @@ +*> \brief DPPSVX computes the solution to system of linear equations A * X = B for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPPSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, +* X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER EQUED, FACT, UPLO +* INTEGER INFO, LDB, LDX, N, NRHS +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), +* $ FERR( * ), S( * ), WORK( * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to +*> compute the solution to a real system of linear equations +*> A * X = B, +*> where A is an N-by-N symmetric positive definite matrix stored in +*> packed format and X and B are N-by-NRHS matrices. +*> +*> Error bounds on the solution and a condition estimate are also +*> provided. +*> \endverbatim +* +*> \par Description: +* ================= +*> +*> \verbatim +*> +*> The following steps are performed: +*> +*> 1. If FACT = 'E', real scaling factors are computed to equilibrate +*> the system: +*> diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B +*> Whether or not the system will be equilibrated depends on the +*> scaling of the matrix A, but if equilibration is used, A is +*> overwritten by diag(S)*A*diag(S) and B by diag(S)*B. +*> +*> 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to +*> factor the matrix A (after equilibration if FACT = 'E') as +*> A = U**T* U, if UPLO = 'U', or +*> A = L * L**T, if UPLO = 'L', +*> where U is an upper triangular matrix and L is a lower triangular +*> matrix. +*> +*> 3. If the leading i-by-i principal minor is not positive definite, +*> then the routine returns with INFO = i. Otherwise, the factored +*> form of A is used to estimate the condition number of the matrix +*> A. If the reciprocal of the condition number is less than machine +*> precision, INFO = N+1 is returned as a warning, but the routine +*> still goes on to solve for X and compute error bounds as +*> described below. +*> +*> 4. The system of equations is solved for X using the factored form +*> of A. +*> +*> 5. Iterative refinement is applied to improve the computed solution +*> matrix and calculate error bounds and backward error estimates +*> for it. +*> +*> 6. If equilibration was used, the matrix X is premultiplied by +*> diag(S) so that it solves the original system before +*> equilibration. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> Specifies whether or not the factored form of the matrix A is +*> supplied on entry, and if not, whether the matrix A should be +*> equilibrated before it is factored. +*> = 'F': On entry, AFP contains the factored form of A. +*> If EQUED = 'Y', the matrix A has been equilibrated +*> with scaling factors given by S. AP and AFP will not +*> be modified. +*> = 'N': The matrix A will be copied to AFP and factored. +*> = 'E': The matrix A will be equilibrated if necessary, then +*> copied to AFP and factored. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> On entry, the upper or lower triangle of the symmetric matrix +*> A, packed columnwise in a linear array, except if FACT = 'F' +*> and EQUED = 'Y', then A must contain the equilibrated matrix +*> diag(S)*A*diag(S). The j-th column of A is stored in the +*> array AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +*> See below for further details. A is not modified if +*> FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. +*> +*> On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by +*> diag(S)*A*diag(S). +*> \endverbatim +*> +*> \param[in,out] AFP +*> \verbatim +*> AFP is DOUBLE PRECISION array, dimension +*> (N*(N+1)/2) +*> If FACT = 'F', then AFP is an input argument and on entry +*> contains the triangular factor U or L from the Cholesky +*> factorization A = U**T*U or A = L*L**T, in the same storage +*> format as A. If EQUED .ne. 'N', then AFP is the factored +*> form of the equilibrated matrix A. +*> +*> If FACT = 'N', then AFP is an output argument and on exit +*> returns the triangular factor U or L from the Cholesky +*> factorization A = U**T * U or A = L * L**T of the original +*> matrix A. +*> +*> If FACT = 'E', then AFP is an output argument and on exit +*> returns the triangular factor U or L from the Cholesky +*> factorization A = U**T * U or A = L * L**T of the equilibrated +*> matrix A (see the description of AP for the form of the +*> equilibrated matrix). +*> \endverbatim +*> +*> \param[in,out] EQUED +*> \verbatim +*> EQUED is CHARACTER*1 +*> Specifies the form of equilibration that was done. +*> = 'N': No equilibration (always true if FACT = 'N'). +*> = 'Y': Equilibration was done, i.e., A has been replaced by +*> diag(S) * A * diag(S). +*> EQUED is an input argument if FACT = 'F'; otherwise, it is an +*> output argument. +*> \endverbatim +*> +*> \param[in,out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N) +*> The scale factors for A; not accessed if EQUED = 'N'. S is +*> an input argument if FACT = 'F'; otherwise, S is an output +*> argument. If FACT = 'F' and EQUED = 'Y', each element of S +*> must be positive. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', +*> B is overwritten by diag(S) * B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to +*> the original system of equations. Note that if EQUED = 'Y', +*> A and B are modified on exit, and the solution to the +*> equilibrated system is inv(diag(S))*X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is 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. +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, and i is +*> <= N: the leading minor of order i of A is +*> not positive definite, so the factorization +*> could not be completed, and the solution has not +*> been computed. RCOND = 0 is returned. +*> = N+1: U is nonsingular, but RCOND is less than machine +*> precision, meaning that the matrix is singular +*> to working precision. Nevertheless, the +*> solution and error bounds are computed because +*> there are a number of situations where the +*> computed solution can be more accurate than the +*> value of RCOND would suggest. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleOTHERsolve +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The packed storage scheme is illustrated by the following example +*> when N = 4, UPLO = 'U': +*> +*> Two-dimensional storage of the symmetric matrix A: +*> +*> a11 a12 a13 a14 +*> a22 a23 a24 +*> a33 a34 (aij = conjg(aji)) +*> a44 +*> +*> Packed storage of the upper triangle of A: +*> +*> AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, + $ X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, UPLO + INTEGER INFO, LDB, LDX, N, NRHS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), + $ FERR( * ), S( * ), WORK( * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, RCEQU + INTEGER I, INFEQU, J + DOUBLE PRECISION AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSP + EXTERNAL LSAME, DLAMCH, DLANSP +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DLAQSP, DPPCON, DPPEQU, DPPRFS, + $ DPPTRF, DPPTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + RCEQU = .FALSE. + ELSE + RCEQU = LSAME( EQUED, 'Y' ) + 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.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) + $ THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -7 + ELSE + IF( RCEQU ) THEN + SMIN = BIGNUM + SMAX = ZERO + DO 10 J = 1, N + SMIN = MIN( SMIN, S( J ) ) + SMAX = MAX( SMAX, S( J ) ) + 10 CONTINUE + IF( SMIN.LE.ZERO ) THEN + INFO = -8 + ELSE IF( N.GT.0 ) THEN + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + ELSE + SCOND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -12 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPPSVX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) + RCEQU = LSAME( EQUED, 'Y' ) + END IF + END IF +* +* Scale the right-hand side. +* + IF( RCEQU ) THEN + DO 30 J = 1, NRHS + DO 20 I = 1, N + B( I, J ) = S( I )*B( I, J ) + 20 CONTINUE + 30 CONTINUE + END IF +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the Cholesky factorization A = U**T * U or A = L * L**T. +* + CALL DCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 ) + CALL DPPTRF( UPLO, N, AFP, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 )THEN + RCOND = ZERO + RETURN + END IF + END IF +* +* Compute the norm of the matrix A. +* + ANORM = DLANSP( 'I', UPLO, N, AP, WORK ) +* +* Compute the reciprocal of the condition number of A. +* + CALL DPPCON( UPLO, N, AFP, ANORM, RCOND, WORK, IWORK, INFO ) +* +* Compute the solution matrix X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DPPTRS( UPLO, N, NRHS, AFP, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, + $ WORK, IWORK, INFO ) +* +* Transform the solution matrix X to a solution of the original +* system. +* + IF( RCEQU ) THEN + DO 50 J = 1, NRHS + DO 40 I = 1, N + X( I, J ) = S( I )*X( I, J ) + 40 CONTINUE + 50 CONTINUE + DO 60 J = 1, NRHS + FERR( J ) = FERR( J ) / SCOND + 60 CONTINUE + END IF +* +* Set INFO = N+1 if the matrix is singular to working precision. +* + IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) + $ INFO = N + 1 +* + RETURN +* +* End of DPPSVX +* + END diff --git a/math/lapack/src/main/fortran/dpptrf.f b/math/lapack/src/main/fortran/dpptrf.f new file mode 100644 index 0000000000..c7f0c35b0f --- /dev/null +++ b/math/lapack/src/main/fortran/dpptrf.f @@ -0,0 +1,240 @@ +*> \brief \b DPPTRF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPPTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPPTRF( UPLO, N, AP, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the leading minor of order i is not +*> positive definite, and the factorization could not be +*> completed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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 ] +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DPPTRF( UPLO, N, AP, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ) +* .. +* +* ===================================================================== +* +* .. 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**T*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**T. +* + 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/math/lapack/src/main/fortran/dpptri.f b/math/lapack/src/main/fortran/dpptri.f new file mode 100644 index 0000000000..8f16de01e2 --- /dev/null +++ b/math/lapack/src/main/fortran/dpptri.f @@ -0,0 +1,188 @@ +*> \brief \b DPPTRI +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPPTRI( UPLO, N, AP, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPPTRI computes the inverse of a real symmetric positive definite +*> matrix A using the Cholesky factorization A = U**T*U or A = L*L**T +*> computed by DPPTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangular factor is stored in AP; +*> = 'L': Lower triangular factor is stored in AP. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> On entry, the triangular factor U or L from the Cholesky +*> factorization A = U**T*U or A = L*L**T, packed columnwise as +*> a linear array. The j-th column of U or L is stored in the +*> array AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. +*> +*> On exit, the upper or lower triangle of the (symmetric) +*> inverse of A, overwriting the input factor U or L. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the (i,i) element of the factor U or L is +*> zero, and the inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DPPTRI( UPLO, N, AP, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, JC, JJ, JJN + DOUBLE PRECISION AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSPR, DTPMV, DTPTRI, XERBLA +* .. +* .. 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( 'DPPTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Invert the triangular Cholesky factor U or L. +* + CALL DTPTRI( UPLO, 'Non-unit', N, AP, INFO ) + IF( INFO.GT.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Compute the product inv(U) * inv(U)**T. +* + JJ = 0 + DO 10 J = 1, N + JC = JJ + 1 + JJ = JJ + J + IF( J.GT.1 ) + $ CALL DSPR( 'Upper', J-1, ONE, AP( JC ), 1, AP ) + AJJ = AP( JJ ) + CALL DSCAL( J, AJJ, AP( JC ), 1 ) + 10 CONTINUE +* + ELSE +* +* Compute the product inv(L)**T * inv(L). +* + JJ = 1 + DO 20 J = 1, N + JJN = JJ + N - J + 1 + AP( JJ ) = DDOT( N-J+1, AP( JJ ), 1, AP( JJ ), 1 ) + IF( J.LT.N ) + $ CALL DTPMV( 'Lower', 'Transpose', 'Non-unit', N-J, + $ AP( JJN ), AP( JJ+1 ), 1 ) + JJ = JJN + 20 CONTINUE + END IF +* + RETURN +* +* End of DPPTRI +* + END diff --git a/math/lapack/src/main/fortran/dpptrs.f b/math/lapack/src/main/fortran/dpptrs.f new file mode 100644 index 0000000000..b4410a5128 --- /dev/null +++ b/math/lapack/src/main/fortran/dpptrs.f @@ -0,0 +1,203 @@ +*> \brief \b DPPTRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPPTRS solves a system of linear equations A*X = B with a symmetric +*> positive definite matrix A in packed storage using the Cholesky +*> factorization A = U**T*U or A = L*L**T computed by DPPTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> The triangular factor U or L from the Cholesky factorization +*> A = U**T*U or A = L*L**T, packed columnwise in a linear +*> array. The j-th column of U or L is stored in the array AP +*> as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DTPSV, 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( LDB.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPPTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B where A = U**T * U. +* + DO 10 I = 1, NRHS +* +* Solve U**T *X = B, overwriting B with X. +* + CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', N, AP, + $ B( 1, I ), 1 ) +* +* Solve U*X = B, overwriting B with X. +* + CALL DTPSV( 'Upper', 'No transpose', 'Non-unit', N, AP, + $ B( 1, I ), 1 ) + 10 CONTINUE + ELSE +* +* Solve A*X = B where A = L * L**T. +* + DO 20 I = 1, NRHS +* +* Solve L*Y = B, overwriting B with X. +* + CALL DTPSV( 'Lower', 'No transpose', 'Non-unit', N, AP, + $ B( 1, I ), 1 ) +* +* Solve L**T *X = Y, overwriting B with X. +* + CALL DTPSV( 'Lower', 'Transpose', 'Non-unit', N, AP, + $ B( 1, I ), 1 ) + 20 CONTINUE + END IF +* + RETURN +* +* End of DPPTRS +* + END diff --git a/math/lapack/src/main/fortran/dptcon.f b/math/lapack/src/main/fortran/dptcon.f new file mode 100644 index 0000000000..84c4ed785f --- /dev/null +++ b/math/lapack/src/main/fortran/dptcon.f @@ -0,0 +1,221 @@ +*> \brief \b DPTCON +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPTCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPTCON computes the reciprocal of the condition number (in the +*> 1-norm) of a real symmetric positive definite tridiagonal matrix +*> using the factorization A = L*D*L**T or A = U**T*D*U computed by +*> DPTTRF. +*> +*> Norm(inv(A)) is computed by a direct method, and the reciprocal of +*> the condition number is computed as +*> RCOND = 1 / (ANORM * norm(inv(A))). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of the diagonal matrix D from the +*> factorization of A, as computed by DPTTRF. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) off-diagonal elements of the unit bidiagonal factor +*> U or L from the factorization of A, as computed by DPTTRF. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is DOUBLE PRECISION +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the +*> 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePTcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The method used is described in Nicholas J. Higham, "Efficient +*> Algorithms for Computing the Condition Number of a Tridiagonal +*> Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IX + DOUBLE PRECISION AINVNM +* .. +* .. External Functions .. + INTEGER IDAMAX + EXTERNAL IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* +* Test the input arguments. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPTCON', -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 +* +* Check that D(1:N) is positive. +* + DO 10 I = 1, N + IF( D( I ).LE.ZERO ) + $ RETURN + 10 CONTINUE +* +* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by +* +* m(i,j) = abs(A(i,j)), i = j, +* m(i,j) = -abs(A(i,j)), i .ne. j, +* +* and e = [ 1, 1, ..., 1 ]**T. Note M(A) = M(L)*D*M(L)**T. +* +* Solve M(L) * x = e. +* + WORK( 1 ) = ONE + DO 20 I = 2, N + WORK( I ) = ONE + WORK( I-1 )*ABS( E( I-1 ) ) + 20 CONTINUE +* +* Solve D * M(L)**T * x = b. +* + WORK( N ) = WORK( N ) / D( N ) + DO 30 I = N - 1, 1, -1 + WORK( I ) = WORK( I ) / D( I ) + WORK( I+1 )*ABS( E( I ) ) + 30 CONTINUE +* +* Compute AINVNM = max(x(i)), 1<=i<=n. +* + IX = IDAMAX( N, WORK, 1 ) + AINVNM = ABS( WORK( IX ) ) +* +* Compute the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + RETURN +* +* End of DPTCON +* + END diff --git a/math/lapack/src/main/fortran/dpteqr.f b/math/lapack/src/main/fortran/dpteqr.f new file mode 100644 index 0000000000..ecfc7755db --- /dev/null +++ b/math/lapack/src/main/fortran/dpteqr.f @@ -0,0 +1,261 @@ +*> \brief \b DPTEQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPTEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER COMPZ +* INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPTEQR computes all eigenvalues and, optionally, eigenvectors of a +*> symmetric positive definite tridiagonal matrix by first factoring the +*> matrix using DPTTRF, and then calling DBDSQR to compute the singular +*> values of the bidiagonal factor. +*> +*> This routine computes the eigenvalues of the positive definite +*> tridiagonal matrix to high relative accuracy. This means that if the +*> eigenvalues range over many orders of magnitude in size, then the +*> small eigenvalues and corresponding eigenvectors will be computed +*> more accurately than, for example, with the standard QR method. +*> +*> The eigenvectors of a full or band symmetric positive definite matrix +*> can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to +*> reduce this matrix to tridiagonal form. (The reduction to tridiagonal +*> form, however, may preclude the possibility of obtaining high +*> relative accuracy in the small eigenvalues of the original matrix, if +*> these eigenvalues range over many orders of magnitude.) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] COMPZ +*> \verbatim +*> COMPZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only. +*> = 'V': Compute eigenvectors of original symmetric +*> matrix also. Array Z contains the orthogonal +*> matrix used to reduce the original matrix to +*> tridiagonal form. +*> = 'I': Compute eigenvectors of tridiagonal matrix also. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the n diagonal elements of the tridiagonal +*> matrix. +*> On normal exit, D contains the eigenvalues, in descending +*> order. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> On entry, the (n-1) subdiagonal elements of the tridiagonal +*> matrix. +*> On exit, E has been destroyed. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, N) +*> On entry, if COMPZ = 'V', the orthogonal matrix used in the +*> reduction to tridiagonal form. +*> On exit, if COMPZ = 'V', the orthonormal eigenvectors of the +*> original symmetric matrix; +*> if COMPZ = 'I', the orthonormal eigenvectors of the +*> tridiagonal matrix. +*> If INFO > 0 on exit, Z contains the eigenvectors associated +*> with only the stored eigenvalues. +*> If COMPZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> COMPZ = 'V' or 'I', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, and i is: +*> <= N the Cholesky factorization of the matrix could +*> not be performed because the i-th principal minor +*> was not positive definite. +*> > N the SVD algorithm failed to converge; +*> if INFO = N+i, i off-diagonal elements of the +*> bidiagonal factor did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePTcomputational +* +* ===================================================================== + SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER COMPZ + INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DBDSQR, DLASET, DPTTRF, XERBLA +* .. +* .. Local Arrays .. + DOUBLE PRECISION C( 1, 1 ), VT( 1, 1 ) +* .. +* .. Local Scalars .. + INTEGER I, ICOMPZ, NRU +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, 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( 'DPTEQR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( ICOMPZ.GT.0 ) + $ Z( 1, 1 ) = ONE + RETURN + END IF + IF( ICOMPZ.EQ.2 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +* +* Call DPTTRF to factor the matrix. +* + CALL DPTTRF( N, D, E, INFO ) + IF( INFO.NE.0 ) + $ RETURN + DO 10 I = 1, N + D( I ) = SQRT( D( I ) ) + 10 CONTINUE + DO 20 I = 1, N - 1 + E( I ) = E( I )*D( I ) + 20 CONTINUE +* +* Call DBDSQR to compute the singular values/vectors of the +* bidiagonal factor. +* + IF( ICOMPZ.GT.0 ) THEN + NRU = N + ELSE + NRU = 0 + END IF + CALL DBDSQR( 'Lower', N, 0, NRU, 0, D, E, VT, 1, Z, LDZ, C, 1, + $ WORK, INFO ) +* +* Square the singular values. +* + IF( INFO.EQ.0 ) THEN + DO 30 I = 1, N + D( I ) = D( I )*D( I ) + 30 CONTINUE + ELSE + INFO = N + INFO + END IF +* + RETURN +* +* End of DPTEQR +* + END diff --git a/math/lapack/src/main/fortran/dptrfs.f b/math/lapack/src/main/fortran/dptrfs.f new file mode 100644 index 0000000000..ca038a8df2 --- /dev/null +++ b/math/lapack/src/main/fortran/dptrfs.f @@ -0,0 +1,395 @@ +*> \brief \b DPTRFS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPTRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, +* BERR, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), +* $ E( * ), EF( * ), FERR( * ), WORK( * ), +* $ X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPTRFS improves the computed solution to a system of linear +*> equations when the coefficient matrix is symmetric positive definite +*> and tridiagonal, and provides error bounds and backward error +*> estimates for the solution. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of the tridiagonal matrix A. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) subdiagonal elements of the tridiagonal matrix A. +*> \endverbatim +*> +*> \param[in] DF +*> \verbatim +*> DF is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of the diagonal matrix D from the +*> factorization computed by DPTTRF. +*> \endverbatim +*> +*> \param[in] EF +*> \verbatim +*> EF is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) subdiagonal elements of the unit bidiagonal factor +*> L from the factorization computed by DPTTRF. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> On entry, the solution matrix X, as computed by DPTTRS. +*> On exit, the improved solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is DOUBLE PRECISION array, dimension (NRHS) +*> The forward error bound for each solution vector +*> X(j) (the j-th column of the solution matrix X). +*> If XTRUE is the true solution corresponding to X(j), FERR(j) +*> is an estimated upper bound for the magnitude of the largest +*> element in (X(j) - XTRUE) divided by the magnitude of the +*> largest element in X(j). +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> ITMAX is the maximum number of steps of iterative refinement. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePTcomputational +* +* ===================================================================== + SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, + $ BERR, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), + $ E( * ), EF( * ), FERR( * ), WORK( * ), + $ X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. 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 .. + INTEGER COUNT, I, IX, J, NZ + DOUBLE PRECISION BI, CX, DX, EPS, EX, LSTRES, S, SAFE1, SAFE2, + $ SAFMIN +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DPTTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL IDAMAX, DLAMCH +* .. +* .. 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( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPTRFS', -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 +* +* NZ = maximum number of nonzero elements in each row of A, plus 1 +* + NZ = 4 + EPS = DLAMCH( 'Epsilon' ) + SAFMIN = DLAMCH( 'Safe minimum' ) + SAFE1 = NZ*SAFMIN + SAFE2 = SAFE1 / EPS +* +* Do for each right hand side +* + DO 90 J = 1, NRHS +* + COUNT = 1 + LSTRES = THREE + 20 CONTINUE +* +* Loop until stopping criterion is satisfied. +* +* Compute residual R = B - A * X. Also compute +* abs(A)*abs(x) + abs(b) for use in the backward error bound. +* + IF( N.EQ.1 ) THEN + BI = B( 1, J ) + DX = D( 1 )*X( 1, J ) + WORK( N+1 ) = BI - DX + WORK( 1 ) = ABS( BI ) + ABS( DX ) + ELSE + BI = B( 1, J ) + DX = D( 1 )*X( 1, J ) + EX = E( 1 )*X( 2, J ) + WORK( N+1 ) = BI - DX - EX + WORK( 1 ) = ABS( BI ) + ABS( DX ) + ABS( EX ) + DO 30 I = 2, N - 1 + BI = B( I, J ) + CX = E( I-1 )*X( I-1, J ) + DX = D( I )*X( I, J ) + EX = E( I )*X( I+1, J ) + WORK( N+I ) = BI - CX - DX - EX + WORK( I ) = ABS( BI ) + ABS( CX ) + ABS( DX ) + ABS( EX ) + 30 CONTINUE + BI = B( N, J ) + CX = E( N-1 )*X( N-1, J ) + DX = D( N )*X( N, J ) + WORK( N+N ) = BI - CX - DX + WORK( N ) = ABS( BI ) + ABS( CX ) + ABS( DX ) + END IF +* +* Compute componentwise relative backward error from formula +* +* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) +* +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. If the i-th component of the denominator is less +* than SAFE2, then SAFE1 is added to the i-th components of the +* numerator and denominator before dividing. +* + S = ZERO + DO 40 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 + 40 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 DPTTRS( N, 1, DF, EF, 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(A))* +* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) +* +* where +* norm(Z) is the magnitude of the largest component of Z +* inv(A) is the inverse of A +* abs(Z) is the componentwise absolute value of the matrix or +* vector Z +* NZ is the maximum number of nonzeros in any row of A, plus 1 +* EPS is machine epsilon +* +* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) +* is incremented by SAFE1 if the i-th component of +* abs(A)*abs(X) + abs(B) is less than SAFE2. +* + DO 50 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 + 50 CONTINUE + IX = IDAMAX( N, WORK, 1 ) + FERR( J ) = WORK( IX ) +* +* Estimate the norm of inv(A). +* +* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by +* +* m(i,j) = abs(A(i,j)), i = j, +* m(i,j) = -abs(A(i,j)), i .ne. j, +* +* and e = [ 1, 1, ..., 1 ]**T. Note M(A) = M(L)*D*M(L)**T. +* +* Solve M(L) * x = e. +* + WORK( 1 ) = ONE + DO 60 I = 2, N + WORK( I ) = ONE + WORK( I-1 )*ABS( EF( I-1 ) ) + 60 CONTINUE +* +* Solve D * M(L)**T * x = b. +* + WORK( N ) = WORK( N ) / DF( N ) + DO 70 I = N - 1, 1, -1 + WORK( I ) = WORK( I ) / DF( I ) + WORK( I+1 )*ABS( EF( I ) ) + 70 CONTINUE +* +* Compute norm(inv(A)) = max(x(i)), 1<=i<=n. +* + IX = IDAMAX( N, WORK, 1 ) + FERR( J ) = FERR( J )*ABS( WORK( IX ) ) +* +* Normalize error. +* + LSTRES = ZERO + DO 80 I = 1, N + LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) + 80 CONTINUE + IF( LSTRES.NE.ZERO ) + $ FERR( J ) = FERR( J ) / LSTRES +* + 90 CONTINUE +* + RETURN +* +* End of DPTRFS +* + END diff --git a/math/lapack/src/main/fortran/dptsv.f b/math/lapack/src/main/fortran/dptsv.f new file mode 100644 index 0000000000..019ed4fbae --- /dev/null +++ b/math/lapack/src/main/fortran/dptsv.f @@ -0,0 +1,167 @@ +*> \brief DPTSV computes the solution to system of linear equations A * X = B for PT matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPTSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPTSV computes the solution to a real system of linear equations +*> A*X = B, where A is an N-by-N symmetric positive definite tridiagonal +*> matrix, and X and B are N-by-NRHS matrices. +*> +*> A is factored as A = L*D*L**T, and the factored form of A is then +*> used to solve the system of equations. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the n diagonal elements of the tridiagonal matrix +*> A. On exit, the n diagonal elements of the diagonal matrix +*> D from the factorization A = L*D*L**T. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> On entry, the (n-1) subdiagonal elements of the tridiagonal +*> matrix A. On exit, the (n-1) subdiagonal elements of the +*> unit bidiagonal factor L from the L*D*L**T factorization of +*> A. (E can also be regarded as the superdiagonal of the unit +*> bidiagonal factor U from the U**T*D*U factorization of A.) +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the leading minor of order i is not +*> positive definite, and the solution has not been +*> computed. The factorization has not been completed +*> unless i = N. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePTsolve +* +* ===================================================================== + SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) +* .. +* +* ===================================================================== +* +* .. External Subroutines .. + EXTERNAL DPTTRF, DPTTRS, 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( LDB.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPTSV ', -INFO ) + RETURN + END IF +* +* Compute the L*D*L**T (or U**T*D*U) factorization of A. +* + CALL DPTTRF( N, D, E, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL DPTTRS( N, NRHS, D, E, B, LDB, INFO ) + END IF + RETURN +* +* End of DPTSV +* + END diff --git a/math/lapack/src/main/fortran/dptsvx.f b/math/lapack/src/main/fortran/dptsvx.f new file mode 100644 index 0000000000..59f344579e --- /dev/null +++ b/math/lapack/src/main/fortran/dptsvx.f @@ -0,0 +1,336 @@ +*> \brief DPTSVX computes the solution to system of linear equations A * X = B for PT matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPTSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, +* RCOND, FERR, BERR, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER FACT +* INTEGER INFO, LDB, LDX, N, NRHS +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), +* $ E( * ), EF( * ), FERR( * ), WORK( * ), +* $ X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPTSVX uses the factorization A = L*D*L**T to compute the solution +*> to a real system of linear equations A*X = B, where A is an N-by-N +*> symmetric positive definite tridiagonal matrix and X and B are +*> N-by-NRHS matrices. +*> +*> Error bounds on the solution and a condition estimate are also +*> provided. +*> \endverbatim +* +*> \par Description: +* ================= +*> +*> \verbatim +*> +*> The following steps are performed: +*> +*> 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L +*> is a unit lower bidiagonal matrix and D is diagonal. The +*> factorization can also be regarded as having the form +*> A = U**T*D*U. +*> +*> 2. If the leading i-by-i principal minor is not positive definite, +*> then the routine returns with INFO = i. Otherwise, the factored +*> form of A is used to estimate the condition number of the matrix +*> A. If the reciprocal of the condition number is less than machine +*> precision, INFO = N+1 is returned as a warning, but the routine +*> still goes on to solve for X and compute error bounds as +*> described below. +*> +*> 3. The system of equations is solved for X using the factored form +*> of A. +*> +*> 4. Iterative refinement is applied to improve the computed solution +*> matrix and calculate error bounds and backward error estimates +*> for it. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> Specifies whether or not the factored form of A has been +*> supplied on entry. +*> = 'F': On entry, DF and EF contain the factored form of A. +*> D, E, DF, and EF will not be modified. +*> = 'N': The matrix A will be copied to DF and EF and +*> factored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of the tridiagonal matrix A. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) subdiagonal elements of the tridiagonal matrix A. +*> \endverbatim +*> +*> \param[in,out] DF +*> \verbatim +*> DF is DOUBLE PRECISION array, dimension (N) +*> If FACT = 'F', then DF is an input argument and on entry +*> contains the n diagonal elements of the diagonal matrix D +*> from the L*D*L**T factorization of A. +*> If FACT = 'N', then DF is an output argument and on exit +*> contains the n diagonal elements of the diagonal matrix D +*> from the L*D*L**T factorization of A. +*> \endverbatim +*> +*> \param[in,out] EF +*> \verbatim +*> EF is DOUBLE PRECISION array, dimension (N-1) +*> If FACT = 'F', then EF is an input argument and on entry +*> contains the (n-1) subdiagonal elements of the unit +*> bidiagonal factor L from the L*D*L**T factorization of A. +*> If FACT = 'N', then EF is an output argument and on exit +*> contains the (n-1) subdiagonal elements of the unit +*> bidiagonal factor L from the L*D*L**T factorization of A. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The N-by-NRHS right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal condition number of the matrix A. If RCOND +*> is less than the machine precision (in particular, if +*> RCOND = 0), the matrix is singular to working precision. +*> This condition is indicated by a return code of INFO > 0. +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is DOUBLE PRECISION array, dimension (NRHS) +*> The forward error bound for each solution vector +*> X(j) (the j-th column of the solution matrix X). +*> If XTRUE is the true solution corresponding to X(j), FERR(j) +*> is an estimated upper bound for the magnitude of the largest +*> element in (X(j) - XTRUE) divided by the magnitude of the +*> largest element in X(j). +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, and i is +*> <= N: the leading minor of order i of A is +*> not positive definite, so the factorization +*> could not be completed, and the solution has not +*> been computed. RCOND = 0 is returned. +*> = N+1: U is nonsingular, but RCOND is less than machine +*> precision, meaning that the matrix is singular +*> to working precision. Nevertheless, the +*> solution and error bounds are computed because +*> there are a number of situations where the +*> computed solution can be more accurate than the +*> value of RCOND would suggest. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePTsolve +* +* ===================================================================== + SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, + $ RCOND, FERR, BERR, WORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER FACT + INTEGER INFO, LDB, LDX, N, NRHS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), + $ E( * ), EF( * ), FERR( * ), WORK( * ), + $ X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOFACT + DOUBLE PRECISION ANORM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANST + EXTERNAL LSAME, DLAMCH, DLANST +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DPTCON, DPTRFS, DPTTRF, DPTTRS, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPTSVX', -INFO ) + RETURN + END IF +* + IF( NOFACT ) THEN +* +* Compute the L*D*L**T (or U**T*D*U) factorization of A. +* + CALL DCOPY( N, D, 1, DF, 1 ) + IF( N.GT.1 ) + $ CALL DCOPY( N-1, E, 1, EF, 1 ) + CALL DPTTRF( N, DF, EF, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 )THEN + RCOND = ZERO + RETURN + END IF + END IF +* +* Compute the norm of the matrix A. +* + ANORM = DLANST( '1', N, D, E ) +* +* Compute the reciprocal of the condition number of A. +* + CALL DPTCON( N, DF, EF, ANORM, RCOND, WORK, INFO ) +* +* Compute the solution vectors X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DPTTRS( N, NRHS, DF, EF, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solutions and +* compute error bounds and backward error estimates for them. +* + CALL DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, + $ WORK, INFO ) +* +* Set INFO = N+1 if the matrix is singular to working precision. +* + IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) + $ INFO = N + 1 +* + RETURN +* +* End of DPTSVX +* + END diff --git a/math/lapack/src/main/fortran/dpttrf.f b/math/lapack/src/main/fortran/dpttrf.f new file mode 100644 index 0000000000..33a67adfa5 --- /dev/null +++ b/math/lapack/src/main/fortran/dpttrf.f @@ -0,0 +1,211 @@ +*> \brief \b DPTTRF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPTTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPTTRF( N, D, E, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPTTRF computes the L*D*L**T factorization of a real symmetric +*> positive definite tridiagonal matrix A. The factorization may also +*> be regarded as having the form A = U**T*D*U. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the n diagonal elements of the tridiagonal matrix +*> A. On exit, the n diagonal elements of the diagonal matrix +*> D from the L*D*L**T factorization of A. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> On entry, the (n-1) subdiagonal elements of the tridiagonal +*> matrix A. On exit, the (n-1) subdiagonal elements of the +*> unit bidiagonal factor L from the L*D*L**T factorization of A. +*> E can also be regarded as the superdiagonal of the unit +*> bidiagonal factor U from the U**T*D*U factorization of A. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> > 0: if INFO = k, the leading minor of order k is not +*> positive definite; if k < N, the factorization could not +*> be completed, while if k = N, the factorization was +*> completed, but D(N) <= 0. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePTcomputational +* +* ===================================================================== + SUBROUTINE DPTTRF( N, D, E, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, I4 + DOUBLE PRECISION EI +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + CALL XERBLA( 'DPTTRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Compute the L*D*L**T (or U**T*D*U) factorization of A. +* + I4 = MOD( N-1, 4 ) + DO 10 I = 1, I4 + IF( D( I ).LE.ZERO ) THEN + INFO = I + GO TO 30 + END IF + EI = E( I ) + E( I ) = EI / D( I ) + D( I+1 ) = D( I+1 ) - E( I )*EI + 10 CONTINUE +* + DO 20 I = I4 + 1, N - 4, 4 +* +* Drop out of the loop if d(i) <= 0: the matrix is not positive +* definite. +* + IF( D( I ).LE.ZERO ) THEN + INFO = I + GO TO 30 + END IF +* +* Solve for e(i) and d(i+1). +* + EI = E( I ) + E( I ) = EI / D( I ) + D( I+1 ) = D( I+1 ) - E( I )*EI +* + IF( D( I+1 ).LE.ZERO ) THEN + INFO = I + 1 + GO TO 30 + END IF +* +* Solve for e(i+1) and d(i+2). +* + EI = E( I+1 ) + E( I+1 ) = EI / D( I+1 ) + D( I+2 ) = D( I+2 ) - E( I+1 )*EI +* + IF( D( I+2 ).LE.ZERO ) THEN + INFO = I + 2 + GO TO 30 + END IF +* +* Solve for e(i+2) and d(i+3). +* + EI = E( I+2 ) + E( I+2 ) = EI / D( I+2 ) + D( I+3 ) = D( I+3 ) - E( I+2 )*EI +* + IF( D( I+3 ).LE.ZERO ) THEN + INFO = I + 3 + GO TO 30 + END IF +* +* Solve for e(i+3) and d(i+4). +* + EI = E( I+3 ) + E( I+3 ) = EI / D( I+3 ) + D( I+4 ) = D( I+4 ) - E( I+3 )*EI + 20 CONTINUE +* +* Check d(n) for positive definiteness. +* + IF( D( N ).LE.ZERO ) + $ INFO = N +* + 30 CONTINUE + RETURN +* +* End of DPTTRF +* + END diff --git a/math/lapack/src/main/fortran/dpttrs.f b/math/lapack/src/main/fortran/dpttrs.f new file mode 100644 index 0000000000..34cbe9b902 --- /dev/null +++ b/math/lapack/src/main/fortran/dpttrs.f @@ -0,0 +1,182 @@ +*> \brief \b DPTTRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPTTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPTTRS solves a tridiagonal system of the form +*> A * X = B +*> using the L*D*L**T factorization of A computed by DPTTRF. D is a +*> diagonal matrix specified in the vector D, L is a unit bidiagonal +*> matrix whose subdiagonal is specified in the vector E, and X and B +*> are N by NRHS matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the tridiagonal matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of the diagonal matrix D from the +*> L*D*L**T factorization of A. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) subdiagonal elements of the unit bidiagonal factor +*> L from the L*D*L**T factorization of A. E can also be regarded +*> as the superdiagonal of the unit bidiagonal factor U from the +*> factorization A = U**T*D*U. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side vectors B for the system of +*> linear equations. +*> On exit, the solution vectors, X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePTcomputational +* +* ===================================================================== + SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER J, JB, NB +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DPTTS2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -2 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPTTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* +* Determine the number of right-hand sides to solve at a time. +* + IF( NRHS.EQ.1 ) THEN + NB = 1 + ELSE + NB = MAX( 1, ILAENV( 1, 'DPTTRS', ' ', N, NRHS, -1, -1 ) ) + END IF +* + IF( NB.GE.NRHS ) THEN + CALL DPTTS2( N, NRHS, D, E, B, LDB ) + ELSE + DO 10 J = 1, NRHS, NB + JB = MIN( NRHS-J+1, NB ) + CALL DPTTS2( N, JB, D, E, B( 1, J ), LDB ) + 10 CONTINUE + END IF +* + RETURN +* +* End of DPTTRS +* + END diff --git a/math/lapack/src/main/fortran/dptts2.f b/math/lapack/src/main/fortran/dptts2.f new file mode 100644 index 0000000000..99e212d60b --- /dev/null +++ b/math/lapack/src/main/fortran/dptts2.f @@ -0,0 +1,158 @@ +*> \brief \b DPTTS2 solves a tridiagonal system of the form AX=B using the L D LH factorization computed by spttrf. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DPTTS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB ) +* +* .. Scalar Arguments .. +* INTEGER LDB, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPTTS2 solves a tridiagonal system of the form +*> A * X = B +*> using the L*D*L**T factorization of A computed by DPTTRF. D is a +*> diagonal matrix specified in the vector D, L is a unit bidiagonal +*> matrix whose subdiagonal is specified in the vector E, and X and B +*> are N by NRHS matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the tridiagonal matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of the diagonal matrix D from the +*> L*D*L**T factorization of A. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) subdiagonal elements of the unit bidiagonal factor +*> L from the L*D*L**T factorization of A. E can also be regarded +*> as the superdiagonal of the unit bidiagonal factor U from the +*> factorization A = U**T*D*U. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side vectors B for the system of +*> linear equations. +*> On exit, the solution vectors, X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doublePTcomputational +* +* ===================================================================== + SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J +* .. +* .. External Subroutines .. + EXTERNAL DSCAL +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.1 ) THEN + IF( N.EQ.1 ) + $ CALL DSCAL( NRHS, 1.D0 / D( 1 ), B, LDB ) + RETURN + END IF +* +* Solve A * X = B using the factorization A = L*D*L**T, +* overwriting each right hand side vector with its solution. +* + DO 30 J = 1, NRHS +* +* Solve L * x = b. +* + DO 10 I = 2, N + B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 ) + 10 CONTINUE +* +* Solve D * L**T * x = b. +* + B( N, J ) = B( N, J ) / D( N ) + DO 20 I = N - 1, 1, -1 + B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I ) + 20 CONTINUE + 30 CONTINUE +* + RETURN +* +* End of DPTTS2 +* + END diff --git a/math/lapack/src/main/fortran/drscl.f b/math/lapack/src/main/fortran/drscl.f new file mode 100644 index 0000000000..9251143680 --- /dev/null +++ b/math/lapack/src/main/fortran/drscl.f @@ -0,0 +1,174 @@ +*> \brief \b DRSCL multiplies a vector by the reciprocal of a real scalar. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DRSCL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DRSCL( N, SA, SX, INCX ) +* +* .. Scalar Arguments .. +* INTEGER INCX, N +* DOUBLE PRECISION SA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION SX( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of components of the vector x. +*> \endverbatim +*> +*> \param[in] SA +*> \verbatim +*> SA is 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. +*> \endverbatim +*> +*> \param[in,out] SX +*> \verbatim +*> SX is DOUBLE PRECISION array, dimension +*> (1+(N-1)*abs(INCX)) +*> The n-element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is 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 +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DRSCL( N, SA, SX, INCX ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION SA +* .. +* .. Array Arguments .. + DOUBLE PRECISION SX( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dsb2st_kernels.f b/math/lapack/src/main/fortran/dsb2st_kernels.f new file mode 100644 index 0000000000..afed5265fc --- /dev/null +++ b/math/lapack/src/main/fortran/dsb2st_kernels.f @@ -0,0 +1,335 @@ +*> \brief \b DSB2ST_KERNELS +* +* @generated from zhb2st_kernels.f, fortran z -> d, Wed Dec 7 08:22:39 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSB2ST_KERNELS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSB2ST_KERNELS( UPLO, WANTZ, TTYPE, +* ST, ED, SWEEP, N, NB, IB, +* A, LDA, V, TAU, LDVT, WORK) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* LOGICAL WANTZ +* INTEGER TTYPE, ST, ED, SWEEP, N, NB, IB, LDA, LDVT +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), V( * ), +* TAU( * ), WORK( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSB2ST_KERNELS is an internal routine used by the DSYTRD_SB2ST +*> subroutine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> @param[in] n +*> The order of the matrix A. +*> +*> @param[in] nb +*> The size of the band. +*> +*> @param[in, out] A +*> A pointer to the matrix A. +*> +*> @param[in] lda +*> The leading dimension of the matrix A. +*> +*> @param[out] V +*> DOUBLE PRECISION array, dimension 2*n if eigenvalues only are +*> requested or to be queried for vectors. +*> +*> @param[out] TAU +*> DOUBLE PRECISION array, dimension (2*n). +*> The scalar factors of the Householder reflectors are stored +*> in this array. +*> +*> @param[in] st +*> internal parameter for indices. +*> +*> @param[in] ed +*> internal parameter for indices. +*> +*> @param[in] sweep +*> internal parameter for indices. +*> +*> @param[in] Vblksiz +*> internal parameter for indices. +*> +*> @param[in] wantz +*> logical which indicate if Eigenvalue are requested or both +*> Eigenvalue/Eigenvectors. +*> +*> @param[in] work +*> Workspace of size nb. +*> +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSB2ST_KERNELS( UPLO, WANTZ, TTYPE, + $ ST, ED, SWEEP, N, NB, IB, + $ A, LDA, V, TAU, LDVT, WORK) +* + IMPLICIT NONE +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + LOGICAL WANTZ + INTEGER TTYPE, ST, ED, SWEEP, N, NB, IB, LDA, LDVT +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), V( * ), + $ TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, + $ ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, J1, J2, LM, LN, VPOS, TAUPOS, + $ DPOS, OFDPOS, AJETER + DOUBLE PRECISION CTMP +* .. +* .. External Subroutines .. + EXTERNAL DLARFG, DLARFX, DLARFY +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. +* .. Executable Statements .. +* + AJETER = IB + LDVT + UPPER = LSAME( UPLO, 'U' ) + + IF( UPPER ) THEN + DPOS = 2 * NB + 1 + OFDPOS = 2 * NB + ELSE + DPOS = 1 + OFDPOS = 2 + ENDIF + +* +* Upper case +* + IF( UPPER ) THEN +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ENDIF +* + IF( TTYPE.EQ.1 ) THEN + LM = ED - ST + 1 +* + V( VPOS ) = ONE + DO 10 I = 1, LM-1 + V( VPOS+I ) = ( A( OFDPOS-I, ST+I ) ) + A( OFDPOS-I, ST+I ) = ZERO + 10 CONTINUE + CTMP = ( A( OFDPOS, ST ) ) + CALL DLARFG( LM, CTMP, V( VPOS+1 ), 1, + $ TAU( TAUPOS ) ) + A( OFDPOS, ST ) = CTMP +* + LM = ED - ST + 1 + CALL DLARFY( UPLO, LM, V( VPOS ), 1, + $ ( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + ENDIF +* + IF( TTYPE.EQ.3 ) THEN +* + LM = ED - ST + 1 + CALL DLARFY( UPLO, LM, V( VPOS ), 1, + $ ( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + ENDIF +* + IF( TTYPE.EQ.2 ) THEN + J1 = ED+1 + J2 = MIN( ED+NB, N ) + LN = ED-ST+1 + LM = J2-J1+1 + IF( LM.GT.0) THEN + CALL DLARFX( 'Left', LN, LM, V( VPOS ), + $ ( TAU( TAUPOS ) ), + $ A( DPOS-NB, J1 ), LDA-1, WORK) +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ENDIF +* + V( VPOS ) = ONE + DO 30 I = 1, LM-1 + V( VPOS+I ) = + $ ( A( DPOS-NB-I, J1+I ) ) + A( DPOS-NB-I, J1+I ) = ZERO + 30 CONTINUE + CTMP = ( A( DPOS-NB, J1 ) ) + CALL DLARFG( LM, CTMP, V( VPOS+1 ), 1, TAU( TAUPOS ) ) + A( DPOS-NB, J1 ) = CTMP +* + CALL DLARFX( 'Right', LN-1, LM, V( VPOS ), + $ TAU( TAUPOS ), + $ A( DPOS-NB+1, J1 ), LDA-1, WORK) + ENDIF + ENDIF +* +* Lower case +* + ELSE +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ENDIF +* + IF( TTYPE.EQ.1 ) THEN + LM = ED - ST + 1 +* + V( VPOS ) = ONE + DO 20 I = 1, LM-1 + V( VPOS+I ) = A( OFDPOS+I, ST-1 ) + A( OFDPOS+I, ST-1 ) = ZERO + 20 CONTINUE + CALL DLARFG( LM, A( OFDPOS, ST-1 ), V( VPOS+1 ), 1, + $ TAU( TAUPOS ) ) +* + LM = ED - ST + 1 +* + CALL DLARFY( UPLO, LM, V( VPOS ), 1, + $ ( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + + ENDIF +* + IF( TTYPE.EQ.3 ) THEN + LM = ED - ST + 1 +* + CALL DLARFY( UPLO, LM, V( VPOS ), 1, + $ ( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + + ENDIF +* + IF( TTYPE.EQ.2 ) THEN + J1 = ED+1 + J2 = MIN( ED+NB, N ) + LN = ED-ST+1 + LM = J2-J1+1 +* + IF( LM.GT.0) THEN + CALL DLARFX( 'Right', LM, LN, V( VPOS ), + $ TAU( TAUPOS ), A( DPOS+NB, ST ), + $ LDA-1, WORK) +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ENDIF +* + V( VPOS ) = ONE + DO 40 I = 1, LM-1 + V( VPOS+I ) = A( DPOS+NB+I, ST ) + A( DPOS+NB+I, ST ) = ZERO + 40 CONTINUE + CALL DLARFG( LM, A( DPOS+NB, ST ), V( VPOS+1 ), 1, + $ TAU( TAUPOS ) ) +* + CALL DLARFX( 'Left', LM, LN-1, V( VPOS ), + $ ( TAU( TAUPOS ) ), + $ A( DPOS+NB-1, ST+1 ), LDA-1, WORK) + + ENDIF + ENDIF + ENDIF +* + RETURN +* +* END OF DSB2ST_KERNELS +* + END diff --git a/math/lapack/src/main/fortran/dsbev.f b/math/lapack/src/main/fortran/dsbev.f new file mode 100644 index 0000000000..416ae221e7 --- /dev/null +++ b/math/lapack/src/main/fortran/dsbev.f @@ -0,0 +1,287 @@ +*> \brief DSBEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSBEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, KD, LDAB, LDZ, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSBEV computes all the eigenvalues and, optionally, eigenvectors of +*> a real symmetric band matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. If UPLO = 'U', the first +*> superdiagonal and the diagonal of the tridiagonal matrix T +*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', +*> the diagonal and first subdiagonal of T are returned in the +*> first two rows of AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is 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. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (max(1,3*N-2)) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHEReigen +* +* ===================================================================== + SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, + $ INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, KD, LDAB, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, WANTZ + INTEGER IINFO, IMAX, INDE, INDWRK, ISCALE + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSB + EXTERNAL LSAME, DLAMCH, DLANSB +* .. +* .. External Subroutines .. + EXTERNAL DLASCL, DSBTRD, DSCAL, DSTEQR, DSTERF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) +* + 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( KD.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -6 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -9 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSBEV ', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( LOWER ) THEN + W( 1 ) = AB( 1, 1 ) + ELSE + W( 1 ) = AB( KD+1, 1 ) + END IF + 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 = DLANSB( 'M', UPLO, N, KD, AB, LDAB, 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 + IF( LOWER ) THEN + CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + END IF +* +* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. +* + INDE = 1 + INDWRK = INDE + N + CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ, + $ WORK( INDWRK ), IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE + CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( 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 +* + RETURN +* +* End of DSBEV +* + END diff --git a/math/lapack/src/main/fortran/dsbev_2stage.f b/math/lapack/src/main/fortran/dsbev_2stage.f new file mode 100644 index 0000000000..12ce333722 --- /dev/null +++ b/math/lapack/src/main/fortran/dsbev_2stage.f @@ -0,0 +1,377 @@ +*> \brief DSBEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSBEV_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSBEV_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, +* WORK, LWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, KD, LDAB, LDZ, N, LWORK +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSBEV_2STAGE computes all the eigenvalues and, optionally, eigenvectors of +*> a real symmetric band matrix A using the 2stage technique for +*> the reduction to tridiagonal. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. If UPLO = 'U', the first +*> superdiagonal and the diagonal of the tridiagonal matrix T +*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', +*> the diagonal and first subdiagonal of T are returned in the +*> first two rows of AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is 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. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension LWORK +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS + N +*> where KD is the size of the band. +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHEReigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSBEV_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, + $ WORK, LWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, KD, LDAB, LDZ, N, LWORK +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, WANTZ, LQUERY + INTEGER IINFO, IMAX, INDE, INDWRK, ISCALE, + $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSB + EXTERNAL LSAME, DLAMCH, DLANSB, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLASCL, DSCAL, DSTEQR, DSTERF, XERBLA + $ DSYTRD_SB2ST +* .. +* .. Intrinsic Functions .. + INTRINSIC SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( 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( KD.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -6 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + WORK( 1 ) = LWMIN + ELSE + IB = ILAENV( 18, 'DSYTRD_SB2ST', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + LWMIN = N + LHTRD + LWTRD + WORK( 1 ) = LWMIN + ENDIF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -11 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSBEV_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( LOWER ) THEN + W( 1 ) = AB( 1, 1 ) + ELSE + W( 1 ) = AB( KD+1, 1 ) + END IF + 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 = DLANSB( 'M', UPLO, N, KD, AB, LDAB, 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 + IF( LOWER ) THEN + CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + END IF +* +* Call DSYTRD_SB2ST to reduce symmetric band matrix to tridiagonal form. +* + INDE = 1 + INDHOUS = INDE + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL DSYTRD_SB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, W, + $ WORK( INDE ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE + CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( 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 workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of DSBEV_2STAGE +* + END diff --git a/math/lapack/src/main/fortran/dsbevd.f b/math/lapack/src/main/fortran/dsbevd.f new file mode 100644 index 0000000000..0fa15c0519 --- /dev/null +++ b/math/lapack/src/main/fortran/dsbevd.f @@ -0,0 +1,360 @@ +*> \brief DSBEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSBEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, +* LWORK, IWORK, LIWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSBEVD computes all the eigenvalues and, optionally, eigenvectors of +*> a real symmetric band matrix A. If eigenvectors are desired, it uses +*> a divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. If UPLO = 'U', the first +*> superdiagonal and the diagonal of the tridiagonal matrix T +*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', +*> the diagonal and first subdiagonal of T are returned in the +*> first two rows of AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is 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. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, +*> dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> IF N <= 1, LWORK must be at least 1. +*> If JOBZ = 'N' and N > 2, LWORK must be at least 2*N. +*> If JOBZ = 'V' and N > 2, LWORK must be at least +*> ( 1 + 5*N + 2*N**2 ). +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK and IWORK +*> arrays, returns these values as the first entries of the WORK +*> and IWORK arrays, and no error message related to LWORK or +*> LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. +*> If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHEReigen +* +* ===================================================================== + SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, + $ LWORK, IWORK, LIWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, INDE, INDWK2, INDWRK, ISCALE, LIWMIN, + $ LLWRK2, LWMIN + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSB + EXTERNAL LSAME, DLAMCH, DLANSB +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASCL, DSBTRD, DSCAL, DSTEDC, + $ DSTERF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + INFO = 0 + IF( N.LE.1 ) THEN + LIWMIN = 1 + LWMIN = 1 + ELSE + IF( WANTZ ) THEN + LIWMIN = 3 + 5*N + LWMIN = 1 + 5*N + 2*N**2 + ELSE + LIWMIN = 1 + LWMIN = 2*N + END IF + END IF + 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( KD.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -6 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSBEVD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + W( 1 ) = AB( 1, 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 = DLANSB( 'M', UPLO, N, KD, AB, LDAB, 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 + IF( LOWER ) THEN + CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + END IF +* +* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. +* + INDE = 1 + INDWRK = INDE + N + INDWK2 = INDWRK + N*N + LLWRK2 = LWORK - INDWK2 + 1 + CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ, + $ WORK( INDWRK ), IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE + CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, + $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO ) + CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N, + $ ZERO, WORK( INDWK2 ), N ) + CALL DLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( N, ONE / SIGMA, W, 1 ) +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN + RETURN +* +* End of DSBEVD +* + END diff --git a/math/lapack/src/main/fortran/dsbevd_2stage.f b/math/lapack/src/main/fortran/dsbevd_2stage.f new file mode 100644 index 0000000000..1968f2b780 --- /dev/null +++ b/math/lapack/src/main/fortran/dsbevd_2stage.f @@ -0,0 +1,412 @@ +*> \brief DSBEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSBEVD_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSBEVD_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, +* WORK, LWORK, IWORK, LIWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSBEVD_2STAGE computes all the eigenvalues and, optionally, eigenvectors of +*> a real symmetric band matrix A using the 2stage technique for +*> the reduction to tridiagonal. If eigenvectors are desired, it uses +*> a divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. If UPLO = 'U', the first +*> superdiagonal and the diagonal of the tridiagonal matrix T +*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', +*> the diagonal and first subdiagonal of T are returned in the +*> first two rows of AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is 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. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension LWORK +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS + N +*> where KD is the size of the band. +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK and IWORK +*> arrays, returns these values as the first entries of the WORK +*> and IWORK arrays, and no error message related to LWORK or +*> LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. +*> If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHEReigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSBEVD_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, + $ WORK, LWORK, IWORK, LIWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, INDE, INDWK2, INDWRK, ISCALE, LIWMIN, + $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS, + $ LLWRK2 + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSB + EXTERNAL LSAME, DLAMCH, DLANSB, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASCL, DSCAL, DSTEDC, + $ DSTERF, XERBLA, DSYTRD_SB2ST +* .. +* .. Intrinsic Functions .. + INTRINSIC SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + INFO = 0 + IF( N.LE.1 ) THEN + LIWMIN = 1 + LWMIN = 1 + ELSE + IB = ILAENV( 18, 'DSYTRD_SB2ST', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + IF( WANTZ ) THEN + LIWMIN = 3 + 5*N + LWMIN = 1 + 5*N + 2*N**2 + ELSE + LIWMIN = 1 + LWMIN = MAX( 2*N, N+LHTRD+LWTRD ) + END IF + END IF + IF( .NOT.( 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( KD.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -6 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSBEVD_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + W( 1 ) = AB( 1, 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 = DLANSB( 'M', UPLO, N, KD, AB, LDAB, 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 + IF( LOWER ) THEN + CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + END IF +* +* Call DSYTRD_SB2ST to reduce band symmetric matrix to tridiagonal form. +* + INDE = 1 + INDHOUS = INDE + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 + INDWK2 = INDWRK + N*N + LLWRK2 = LWORK - INDWK2 + 1 +* + CALL DSYTRD_SB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, W, + $ WORK( INDE ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE + CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, + $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO ) + CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N, + $ ZERO, WORK( INDWK2 ), N ) + CALL DLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( N, ONE / SIGMA, W, 1 ) +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN + RETURN +* +* End of DSBEVD_2STAGE +* + END diff --git a/math/lapack/src/main/fortran/dsbevx.f b/math/lapack/src/main/fortran/dsbevx.f new file mode 100644 index 0000000000..5e6d6423f9 --- /dev/null +++ b/math/lapack/src/main/fortran/dsbevx.f @@ -0,0 +1,543 @@ +*> \brief DSBEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSBEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, +* VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, +* IFAIL, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSBEVX computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric band matrix A. Eigenvalues and eigenvectors can +*> be selected by specifying either a range of values or a range of +*> indices for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found; +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found; +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. If UPLO = 'U', the first +*> superdiagonal and the diagonal of the tridiagonal matrix T +*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', +*> the diagonal and first subdiagonal of T are returned in the +*> first two rows of AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ, N) +*> If JOBZ = 'V', the N-by-N orthogonal matrix used in the +*> reduction to tridiagonal form. +*> If JOBZ = 'N', the array Q is not referenced. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. If JOBZ = 'V', then +*> LDQ >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing AB to tridiagonal form. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*DLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*DLAMCH('S'). +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first M elements contain the selected eigenvalues in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If an eigenvector fails to converge, then that column of Z +*> contains the latest approximation to the eigenvector, and the +*> index of the eigenvector is returned in IFAIL. +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (7*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (N) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvectors that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, then i eigenvectors failed to converge. +*> Their indices are stored in array IFAIL. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHEReigen +* +* ===================================================================== + SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, + $ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, + $ IFAIL, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ + CHARACTER ORDER + INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + $ INDISP, INDIWO, INDWRK, ISCALE, ITMP1, J, JJ, + $ NSPLIT + DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSB + EXTERNAL LSAME, DLAMCH, DLANSB +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DSBTRD, DSCAL, + $ DSTEBZ, DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) + LOWER = LSAME( UPLO, 'L' ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( KD.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -7 + ELSE IF( WANTZ .AND. LDQ.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -11 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -13 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) + $ INFO = -18 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSBEVX', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + M = 1 + IF( LOWER ) THEN + TMP1 = AB( 1, 1 ) + ELSE + TMP1 = AB( KD+1, 1 ) + END IF + IF( VALEIG ) THEN + IF( .NOT.( VL.LT.TMP1 .AND. VU.GE.TMP1 ) ) + $ M = 0 + END IF + IF( M.EQ.1 ) THEN + W( 1 ) = TMP1 + IF( WANTZ ) + $ Z( 1, 1 ) = ONE + END IF + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF( VALEIG ) THEN + VLL = VL + VUU = VU + ELSE + VLL = ZERO + VUU = ZERO + END IF + ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK ) + 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 + IF( LOWER ) THEN + CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF +* +* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. +* + INDD = 1 + INDE = INDD + N + INDWRK = INDE + N + CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, WORK( INDD ), + $ WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO ) +* +* If all eigenvalues are desired and ABSTOL is less than or equal +* to zero, then call DSTERF or SSTEQR. If this fails for some +* eigenvalue, then try DSTEBZ. +* + TEST = .FALSE. + IF (INDEIG) THEN + IF (IL.EQ.1 .AND. IU.EQ.N) THEN + TEST = .TRUE. + END IF + END IF + IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN + CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) + INDEE = INDWRK + 2*N + IF( .NOT.WANTZ ) THEN + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTERF( N, W, WORK( INDEE ), INFO ) + ELSE + CALL DLACPY( 'A', N, N, Q, LDQ, Z, LDZ ) + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, + $ WORK( INDWRK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 10 I = 1, N + IFAIL( I ) = 0 + 10 CONTINUE + END IF + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF +* +* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDIBL = 1 + INDISP = INDIBL + N + INDIWO = INDISP + N + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by DSTEIN. +* + DO 20 J = 1, M + CALL DCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 ) + CALL DGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO, + $ Z( 1, J ), 1 ) + 20 CONTINUE + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 30 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 50 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 40 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 40 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 50 CONTINUE + END IF +* + RETURN +* +* End of DSBEVX +* + END diff --git a/math/lapack/src/main/fortran/dsbevx_2stage.f b/math/lapack/src/main/fortran/dsbevx_2stage.f new file mode 100644 index 0000000000..9e120e5e5a --- /dev/null +++ b/math/lapack/src/main/fortran/dsbevx_2stage.f @@ -0,0 +1,633 @@ +*> \brief DSBEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSBEVX_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, +* LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, +* LDZ, WORK, LWORK, IWORK, IFAIL, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSBEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric band matrix A using the 2stage technique for +*> the reduction to tridiagonal. Eigenvalues and eigenvectors can +*> be selected by specifying either a range of values or a range of +*> indices for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found; +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found; +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. If UPLO = 'U', the first +*> superdiagonal and the diagonal of the tridiagonal matrix T +*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', +*> the diagonal and first subdiagonal of T are returned in the +*> first two rows of AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ, N) +*> If JOBZ = 'V', the N-by-N orthogonal matrix used in the +*> reduction to tridiagonal form. +*> If JOBZ = 'N', the array Q is not referenced. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. If JOBZ = 'V', then +*> LDQ >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing AB to tridiagonal form. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*DLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*DLAMCH('S'). +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first M elements contain the selected eigenvalues in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If an eigenvector fails to converge, then that column of Z +*> contains the latest approximation to the eigenvector, and the +*> index of the eigenvector is returned in IFAIL. +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, 7*N, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS + 2*N +*> where KD is the size of the band. +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (N) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvectors that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, then i eigenvectors failed to converge. +*> Their indices are stored in array IFAIL. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHEReigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, + $ LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, + $ LDZ, WORK, LWORK, IWORK, IFAIL, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ, + $ LQUERY + CHARACTER ORDER + INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + $ INDISP, INDIWO, INDWRK, ISCALE, ITMP1, J, JJ, + $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS, + $ NSPLIT + DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSB + EXTERNAL LSAME, DLAMCH, DLANSB, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DSCAL, + $ DSTEBZ, DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA, + $ DSYTRD_SB2ST +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( KD.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -7 + ELSE IF( WANTZ .AND. LDQ.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -11 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -13 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) + $ INFO = -18 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + WORK( 1 ) = LWMIN + ELSE + IB = ILAENV( 18, 'DSYTRD_SB2ST', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + LWMIN = 2*N + LHTRD + LWTRD + WORK( 1 ) = LWMIN + ENDIF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -20 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSBEVX_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + M = 1 + IF( LOWER ) THEN + TMP1 = AB( 1, 1 ) + ELSE + TMP1 = AB( KD+1, 1 ) + END IF + IF( VALEIG ) THEN + IF( .NOT.( VL.LT.TMP1 .AND. VU.GE.TMP1 ) ) + $ M = 0 + END IF + IF( M.EQ.1 ) THEN + W( 1 ) = TMP1 + IF( WANTZ ) + $ Z( 1, 1 ) = ONE + END IF + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF( VALEIG ) THEN + VLL = VL + VUU = VU + ELSE + VLL = ZERO + VUU = ZERO + END IF + ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK ) + 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 + IF( LOWER ) THEN + CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF +* +* Call DSYTRD_SB2ST to reduce symmetric band matrix to tridiagonal form. +* + INDD = 1 + INDE = INDD + N + INDHOUS = INDE + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL DSYTRD_SB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, WORK( INDD ), + $ WORK( INDE ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* If all eigenvalues are desired and ABSTOL is less than or equal +* to zero, then call DSTERF or SSTEQR. If this fails for some +* eigenvalue, then try DSTEBZ. +* + TEST = .FALSE. + IF (INDEIG) THEN + IF (IL.EQ.1 .AND. IU.EQ.N) THEN + TEST = .TRUE. + END IF + END IF + IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN + CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) + INDEE = INDWRK + 2*N + IF( .NOT.WANTZ ) THEN + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTERF( N, W, WORK( INDEE ), INFO ) + ELSE + CALL DLACPY( 'A', N, N, Q, LDQ, Z, LDZ ) + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, + $ WORK( INDWRK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 10 I = 1, N + IFAIL( I ) = 0 + 10 CONTINUE + END IF + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF +* +* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDIBL = 1 + INDISP = INDIBL + N + INDIWO = INDISP + N + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by DSTEIN. +* + DO 20 J = 1, M + CALL DCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 ) + CALL DGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO, + $ Z( 1, J ), 1 ) + 20 CONTINUE + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 30 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 50 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 40 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 40 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 50 CONTINUE + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of DSBEVX_2STAGE +* + END diff --git a/math/lapack/src/main/fortran/dsbgst.f b/math/lapack/src/main/fortran/dsbgst.f new file mode 100644 index 0000000000..3adfeb919c --- /dev/null +++ b/math/lapack/src/main/fortran/dsbgst.f @@ -0,0 +1,1434 @@ +*> \brief \b DSBGST +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSBGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, +* LDX, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, VECT +* INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), WORK( * ), +* $ X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSBGST reduces a real symmetric-definite banded generalized +*> eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y, +*> such that C has the same bandwidth as A. +*> +*> B must have been previously factorized as S**T*S by DPBSTF, using a +*> split Cholesky factorization. A is overwritten by C = X**T*A*X, where +*> X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the +*> bandwidth of A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] VECT +*> \verbatim +*> VECT is CHARACTER*1 +*> = 'N': do not form the transformation matrix X; +*> = 'V': form X. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in] KA +*> \verbatim +*> KA is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KA >= 0. +*> \endverbatim +*> +*> \param[in] KB +*> \verbatim +*> KB is INTEGER +*> The number of superdiagonals of the matrix B if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first ka+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). +*> +*> On exit, the transformed matrix X**T*A*X, stored in the same +*> format as A. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KA+1. +*> \endverbatim +*> +*> \param[in] BB +*> \verbatim +*> BB is DOUBLE PRECISION array, dimension (LDBB,N) +*> The banded factor S from the split Cholesky factorization of +*> B, as returned by DPBSTF, stored in the first KB+1 rows of +*> the array. +*> \endverbatim +*> +*> \param[in] LDBB +*> \verbatim +*> LDBB is INTEGER +*> The leading dimension of the array BB. LDBB >= KB+1. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,N) +*> If VECT = 'V', the n-by-n matrix X. +*> If VECT = 'N', the array X is not referenced. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. +*> LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, + $ LDX, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO, VECT + INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), WORK( * ), + $ X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPDATE, UPPER, WANTX + INTEGER I, I0, I1, I2, INCA, J, J1, J1T, J2, J2T, K, + $ KA1, KB1, KBT, L, M, NR, NRT, NX + DOUBLE PRECISION BII, RA, RA1, T +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGER, DLAR2V, DLARGV, DLARTG, DLARTV, DLASET, + $ DROT, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + WANTX = LSAME( VECT, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + KA1 = KA + 1 + KB1 = KB + 1 + INFO = 0 + IF( .NOT.WANTX .AND. .NOT.LSAME( VECT, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KA.LT.0 ) THEN + INFO = -4 + ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN + INFO = -5 + ELSE IF( LDAB.LT.KA+1 ) THEN + INFO = -7 + ELSE IF( LDBB.LT.KB+1 ) THEN + INFO = -9 + ELSE IF( LDX.LT.1 .OR. WANTX .AND. LDX.LT.MAX( 1, N ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSBGST', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + INCA = LDAB*KA1 +* +* Initialize X to the unit matrix, if needed +* + IF( WANTX ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, X, LDX ) +* +* Set M to the splitting point m. It must be the same value as is +* used in DPBSTF. The chosen value allows the arrays WORK and RWORK +* to be of dimension (N). +* + M = ( N+KB ) / 2 +* +* The routine works in two phases, corresponding to the two halves +* of the split Cholesky factorization of B as S**T*S where +* +* S = ( U ) +* ( M L ) +* +* with U upper triangular of order m, and L lower triangular of +* order n-m. S has the same bandwidth as B. +* +* S is treated as a product of elementary matrices: +* +* S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n) +* +* where S(i) is determined by the i-th row of S. +* +* In phase 1, the index i takes the values n, n-1, ... , m+1; +* in phase 2, it takes the values 1, 2, ... , m. +* +* For each value of i, the current matrix A is updated by forming +* inv(S(i))**T*A*inv(S(i)). This creates a triangular bulge outside +* the band of A. The bulge is then pushed down toward the bottom of +* A in phase 1, and up toward the top of A in phase 2, by applying +* plane rotations. +* +* There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1 +* of them are linearly independent, so annihilating a bulge requires +* only 2*kb-1 plane rotations. The rotations are divided into a 1st +* set of kb-1 rotations, and a 2nd set of kb rotations. +* +* Wherever possible, rotations are generated and applied in vector +* operations of length NR between the indices J1 and J2 (sometimes +* replaced by modified values NRT, J1T or J2T). +* +* The cosines and sines of the rotations are stored in the array +* WORK. The cosines of the 1st set of rotations are stored in +* elements n+2:n+m-kb-1 and the sines of the 1st set in elements +* 2:m-kb-1; the cosines of the 2nd set are stored in elements +* n+m-kb+1:2*n and the sines of the second set in elements m-kb+1:n. +* +* The bulges are not formed explicitly; nonzero elements outside the +* band are created only when they are required for generating new +* rotations; they are stored in the array WORK, in positions where +* they are later overwritten by the sines of the rotations which +* annihilate them. +* +* **************************** Phase 1 ***************************** +* +* The logical structure of this phase is: +* +* UPDATE = .TRUE. +* DO I = N, M + 1, -1 +* use S(i) to update A and create a new bulge +* apply rotations to push all bulges KA positions downward +* END DO +* UPDATE = .FALSE. +* DO I = M + KA + 1, N - 1 +* apply rotations to push all bulges KA positions downward +* END DO +* +* To avoid duplicating code, the two loops are merged. +* + UPDATE = .TRUE. + I = N + 1 + 10 CONTINUE + IF( UPDATE ) THEN + I = I - 1 + KBT = MIN( KB, I-1 ) + I0 = I - 1 + I1 = MIN( N, I+KA ) + I2 = I - KBT + KA1 + IF( I.LT.M+1 ) THEN + UPDATE = .FALSE. + I = I + 1 + I0 = M + IF( KA.EQ.0 ) + $ GO TO 480 + GO TO 10 + END IF + ELSE + I = I + KA + IF( I.GT.N-1 ) + $ GO TO 480 + END IF +* + IF( UPPER ) THEN +* +* Transform A, working with the upper triangle +* + IF( UPDATE ) THEN +* +* Form inv(S(i))**T * A * inv(S(i)) +* + BII = BB( KB1, I ) + DO 20 J = I, I1 + AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII + 20 CONTINUE + DO 30 J = MAX( 1, I-KA ), I + AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII + 30 CONTINUE + DO 60 K = I - KBT, I - 1 + DO 40 J = I - KBT, K + AB( J-K+KA1, K ) = AB( J-K+KA1, K ) - + $ BB( J-I+KB1, I )*AB( K-I+KA1, I ) - + $ BB( K-I+KB1, I )*AB( J-I+KA1, I ) + + $ AB( KA1, I )*BB( J-I+KB1, I )* + $ BB( K-I+KB1, I ) + 40 CONTINUE + DO 50 J = MAX( 1, I-KA ), I - KBT - 1 + AB( J-K+KA1, K ) = AB( J-K+KA1, K ) - + $ BB( K-I+KB1, I )*AB( J-I+KA1, I ) + 50 CONTINUE + 60 CONTINUE + DO 80 J = I, I1 + DO 70 K = MAX( J-KA, I-KBT ), I - 1 + AB( K-J+KA1, J ) = AB( K-J+KA1, J ) - + $ BB( K-I+KB1, I )*AB( I-J+KA1, J ) + 70 CONTINUE + 80 CONTINUE +* + IF( WANTX ) THEN +* +* post-multiply X by inv(S(i)) +* + CALL DSCAL( N-M, ONE / BII, X( M+1, I ), 1 ) + IF( KBT.GT.0 ) + $ CALL DGER( N-M, KBT, -ONE, X( M+1, I ), 1, + $ BB( KB1-KBT, I ), 1, X( M+1, I-KBT ), LDX ) + END IF +* +* store a(i,i1) in RA1 for use in next loop over K +* + RA1 = AB( I-I1+KA1, I1 ) + END IF +* +* Generate and apply vectors of rotations to chase all the +* existing bulges KA positions down toward the bottom of the +* band +* + DO 130 K = 1, KB - 1 + IF( UPDATE ) THEN +* +* Determine the rotations which would annihilate the bulge +* which has in theory just been created +* + IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN +* +* generate rotation to annihilate a(i,i-k+ka+1) +* + CALL DLARTG( AB( K+1, I-K+KA ), RA1, + $ WORK( N+I-K+KA-M ), WORK( I-K+KA-M ), + $ RA ) +* +* create nonzero element a(i-k,i-k+ka+1) outside the +* band and store it in WORK(i-k) +* + T = -BB( KB1-K, I )*RA1 + WORK( I-K ) = WORK( N+I-K+KA-M )*T - + $ WORK( I-K+KA-M )*AB( 1, I-K+KA ) + AB( 1, I-K+KA ) = WORK( I-K+KA-M )*T + + $ WORK( N+I-K+KA-M )*AB( 1, I-K+KA ) + RA1 = RA + END IF + END IF + J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1 + NR = ( N-J2+KA ) / KA1 + J1 = J2 + ( NR-1 )*KA1 + IF( UPDATE ) THEN + J2T = MAX( J2, I+2*KA-K+1 ) + ELSE + J2T = J2 + END IF + NRT = ( N-J2T+KA ) / KA1 + DO 90 J = J2T, J1, KA1 +* +* create nonzero element a(j-ka,j+1) outside the band +* and store it in WORK(j-m) +* + WORK( J-M ) = WORK( J-M )*AB( 1, J+1 ) + AB( 1, J+1 ) = WORK( N+J-M )*AB( 1, J+1 ) + 90 CONTINUE +* +* generate rotations in 1st set to annihilate elements which +* have been created outside the band +* + IF( NRT.GT.0 ) + $ CALL DLARGV( NRT, AB( 1, J2T ), INCA, WORK( J2T-M ), KA1, + $ WORK( N+J2T-M ), KA1 ) + IF( NR.GT.0 ) THEN +* +* apply rotations in 1st set from the right +* + DO 100 L = 1, KA - 1 + CALL DLARTV( NR, AB( KA1-L, J2 ), INCA, + $ AB( KA-L, J2+1 ), INCA, WORK( N+J2-M ), + $ WORK( J2-M ), KA1 ) + 100 CONTINUE +* +* apply rotations in 1st set from both sides to diagonal +* blocks +* + CALL DLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ), + $ AB( KA, J2+1 ), INCA, WORK( N+J2-M ), + $ WORK( J2-M ), KA1 ) +* + END IF +* +* start applying rotations in 1st set from the left +* + DO 110 L = KA - 1, KB - K + 1, -1 + NRT = ( N-J2+L ) / KA1 + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA, + $ AB( L+1, J2+KA1-L ), INCA, + $ WORK( N+J2-M ), WORK( J2-M ), KA1 ) + 110 CONTINUE +* + IF( WANTX ) THEN +* +* post-multiply X by product of rotations in 1st set +* + DO 120 J = J2, J1, KA1 + CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1, + $ WORK( N+J-M ), WORK( J-M ) ) + 120 CONTINUE + END IF + 130 CONTINUE +* + IF( UPDATE ) THEN + IF( I2.LE.N .AND. KBT.GT.0 ) THEN +* +* create nonzero element a(i-kbt,i-kbt+ka+1) outside the +* band and store it in WORK(i-kbt) +* + WORK( I-KBT ) = -BB( KB1-KBT, I )*RA1 + END IF + END IF +* + DO 170 K = KB, 1, -1 + IF( UPDATE ) THEN + J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1 + ELSE + J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1 + END IF +* +* finish applying rotations in 2nd set from the left +* + DO 140 L = KB - K, 1, -1 + NRT = ( N-J2+KA+L ) / KA1 + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( L, J2-L+1 ), INCA, + $ AB( L+1, J2-L+1 ), INCA, WORK( N+J2-KA ), + $ WORK( J2-KA ), KA1 ) + 140 CONTINUE + NR = ( N-J2+KA ) / KA1 + J1 = J2 + ( NR-1 )*KA1 + DO 150 J = J1, J2, -KA1 + WORK( J ) = WORK( J-KA ) + WORK( N+J ) = WORK( N+J-KA ) + 150 CONTINUE + DO 160 J = J2, J1, KA1 +* +* create nonzero element a(j-ka,j+1) outside the band +* and store it in WORK(j) +* + WORK( J ) = WORK( J )*AB( 1, J+1 ) + AB( 1, J+1 ) = WORK( N+J )*AB( 1, J+1 ) + 160 CONTINUE + IF( UPDATE ) THEN + IF( I-K.LT.N-KA .AND. K.LE.KBT ) + $ WORK( I-K+KA ) = WORK( I-K ) + END IF + 170 CONTINUE +* + DO 210 K = KB, 1, -1 + J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1 + NR = ( N-J2+KA ) / KA1 + J1 = J2 + ( NR-1 )*KA1 + IF( NR.GT.0 ) THEN +* +* generate rotations in 2nd set to annihilate elements +* which have been created outside the band +* + CALL DLARGV( NR, AB( 1, J2 ), INCA, WORK( J2 ), KA1, + $ WORK( N+J2 ), KA1 ) +* +* apply rotations in 2nd set from the right +* + DO 180 L = 1, KA - 1 + CALL DLARTV( NR, AB( KA1-L, J2 ), INCA, + $ AB( KA-L, J2+1 ), INCA, WORK( N+J2 ), + $ WORK( J2 ), KA1 ) + 180 CONTINUE +* +* apply rotations in 2nd set from both sides to diagonal +* blocks +* + CALL DLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ), + $ AB( KA, J2+1 ), INCA, WORK( N+J2 ), + $ WORK( J2 ), KA1 ) +* + END IF +* +* start applying rotations in 2nd set from the left +* + DO 190 L = KA - 1, KB - K + 1, -1 + NRT = ( N-J2+L ) / KA1 + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA, + $ AB( L+1, J2+KA1-L ), INCA, WORK( N+J2 ), + $ WORK( J2 ), KA1 ) + 190 CONTINUE +* + IF( WANTX ) THEN +* +* post-multiply X by product of rotations in 2nd set +* + DO 200 J = J2, J1, KA1 + CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1, + $ WORK( N+J ), WORK( J ) ) + 200 CONTINUE + END IF + 210 CONTINUE +* + DO 230 K = 1, KB - 1 + J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1 +* +* finish applying rotations in 1st set from the left +* + DO 220 L = KB - K, 1, -1 + NRT = ( N-J2+L ) / KA1 + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA, + $ AB( L+1, J2+KA1-L ), INCA, + $ WORK( N+J2-M ), WORK( J2-M ), KA1 ) + 220 CONTINUE + 230 CONTINUE +* + IF( KB.GT.1 ) THEN + DO 240 J = N - 1, I - KB + 2*KA + 1, -1 + WORK( N+J-M ) = WORK( N+J-KA-M ) + WORK( J-M ) = WORK( J-KA-M ) + 240 CONTINUE + END IF +* + ELSE +* +* Transform A, working with the lower triangle +* + IF( UPDATE ) THEN +* +* Form inv(S(i))**T * A * inv(S(i)) +* + BII = BB( 1, I ) + DO 250 J = I, I1 + AB( J-I+1, I ) = AB( J-I+1, I ) / BII + 250 CONTINUE + DO 260 J = MAX( 1, I-KA ), I + AB( I-J+1, J ) = AB( I-J+1, J ) / BII + 260 CONTINUE + DO 290 K = I - KBT, I - 1 + DO 270 J = I - KBT, K + AB( K-J+1, J ) = AB( K-J+1, J ) - + $ BB( I-J+1, J )*AB( I-K+1, K ) - + $ BB( I-K+1, K )*AB( I-J+1, J ) + + $ AB( 1, I )*BB( I-J+1, J )* + $ BB( I-K+1, K ) + 270 CONTINUE + DO 280 J = MAX( 1, I-KA ), I - KBT - 1 + AB( K-J+1, J ) = AB( K-J+1, J ) - + $ BB( I-K+1, K )*AB( I-J+1, J ) + 280 CONTINUE + 290 CONTINUE + DO 310 J = I, I1 + DO 300 K = MAX( J-KA, I-KBT ), I - 1 + AB( J-K+1, K ) = AB( J-K+1, K ) - + $ BB( I-K+1, K )*AB( J-I+1, I ) + 300 CONTINUE + 310 CONTINUE +* + IF( WANTX ) THEN +* +* post-multiply X by inv(S(i)) +* + CALL DSCAL( N-M, ONE / BII, X( M+1, I ), 1 ) + IF( KBT.GT.0 ) + $ CALL DGER( N-M, KBT, -ONE, X( M+1, I ), 1, + $ BB( KBT+1, I-KBT ), LDBB-1, + $ X( M+1, I-KBT ), LDX ) + END IF +* +* store a(i1,i) in RA1 for use in next loop over K +* + RA1 = AB( I1-I+1, I ) + END IF +* +* Generate and apply vectors of rotations to chase all the +* existing bulges KA positions down toward the bottom of the +* band +* + DO 360 K = 1, KB - 1 + IF( UPDATE ) THEN +* +* Determine the rotations which would annihilate the bulge +* which has in theory just been created +* + IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN +* +* generate rotation to annihilate a(i-k+ka+1,i) +* + CALL DLARTG( AB( KA1-K, I ), RA1, WORK( N+I-K+KA-M ), + $ WORK( I-K+KA-M ), RA ) +* +* create nonzero element a(i-k+ka+1,i-k) outside the +* band and store it in WORK(i-k) +* + T = -BB( K+1, I-K )*RA1 + WORK( I-K ) = WORK( N+I-K+KA-M )*T - + $ WORK( I-K+KA-M )*AB( KA1, I-K ) + AB( KA1, I-K ) = WORK( I-K+KA-M )*T + + $ WORK( N+I-K+KA-M )*AB( KA1, I-K ) + RA1 = RA + END IF + END IF + J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1 + NR = ( N-J2+KA ) / KA1 + J1 = J2 + ( NR-1 )*KA1 + IF( UPDATE ) THEN + J2T = MAX( J2, I+2*KA-K+1 ) + ELSE + J2T = J2 + END IF + NRT = ( N-J2T+KA ) / KA1 + DO 320 J = J2T, J1, KA1 +* +* create nonzero element a(j+1,j-ka) outside the band +* and store it in WORK(j-m) +* + WORK( J-M ) = WORK( J-M )*AB( KA1, J-KA+1 ) + AB( KA1, J-KA+1 ) = WORK( N+J-M )*AB( KA1, J-KA+1 ) + 320 CONTINUE +* +* generate rotations in 1st set to annihilate elements which +* have been created outside the band +* + IF( NRT.GT.0 ) + $ CALL DLARGV( NRT, AB( KA1, J2T-KA ), INCA, WORK( J2T-M ), + $ KA1, WORK( N+J2T-M ), KA1 ) + IF( NR.GT.0 ) THEN +* +* apply rotations in 1st set from the left +* + DO 330 L = 1, KA - 1 + CALL DLARTV( NR, AB( L+1, J2-L ), INCA, + $ AB( L+2, J2-L ), INCA, WORK( N+J2-M ), + $ WORK( J2-M ), KA1 ) + 330 CONTINUE +* +* apply rotations in 1st set from both sides to diagonal +* blocks +* + CALL DLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ), + $ INCA, WORK( N+J2-M ), WORK( J2-M ), KA1 ) +* + END IF +* +* start applying rotations in 1st set from the right +* + DO 340 L = KA - 1, KB - K + 1, -1 + NRT = ( N-J2+L ) / KA1 + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA, + $ AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ), + $ WORK( J2-M ), KA1 ) + 340 CONTINUE +* + IF( WANTX ) THEN +* +* post-multiply X by product of rotations in 1st set +* + DO 350 J = J2, J1, KA1 + CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1, + $ WORK( N+J-M ), WORK( J-M ) ) + 350 CONTINUE + END IF + 360 CONTINUE +* + IF( UPDATE ) THEN + IF( I2.LE.N .AND. KBT.GT.0 ) THEN +* +* create nonzero element a(i-kbt+ka+1,i-kbt) outside the +* band and store it in WORK(i-kbt) +* + WORK( I-KBT ) = -BB( KBT+1, I-KBT )*RA1 + END IF + END IF +* + DO 400 K = KB, 1, -1 + IF( UPDATE ) THEN + J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1 + ELSE + J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1 + END IF +* +* finish applying rotations in 2nd set from the right +* + DO 370 L = KB - K, 1, -1 + NRT = ( N-J2+KA+L ) / KA1 + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( KA1-L+1, J2-KA ), INCA, + $ AB( KA1-L, J2-KA+1 ), INCA, + $ WORK( N+J2-KA ), WORK( J2-KA ), KA1 ) + 370 CONTINUE + NR = ( N-J2+KA ) / KA1 + J1 = J2 + ( NR-1 )*KA1 + DO 380 J = J1, J2, -KA1 + WORK( J ) = WORK( J-KA ) + WORK( N+J ) = WORK( N+J-KA ) + 380 CONTINUE + DO 390 J = J2, J1, KA1 +* +* create nonzero element a(j+1,j-ka) outside the band +* and store it in WORK(j) +* + WORK( J ) = WORK( J )*AB( KA1, J-KA+1 ) + AB( KA1, J-KA+1 ) = WORK( N+J )*AB( KA1, J-KA+1 ) + 390 CONTINUE + IF( UPDATE ) THEN + IF( I-K.LT.N-KA .AND. K.LE.KBT ) + $ WORK( I-K+KA ) = WORK( I-K ) + END IF + 400 CONTINUE +* + DO 440 K = KB, 1, -1 + J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1 + NR = ( N-J2+KA ) / KA1 + J1 = J2 + ( NR-1 )*KA1 + IF( NR.GT.0 ) THEN +* +* generate rotations in 2nd set to annihilate elements +* which have been created outside the band +* + CALL DLARGV( NR, AB( KA1, J2-KA ), INCA, WORK( J2 ), KA1, + $ WORK( N+J2 ), KA1 ) +* +* apply rotations in 2nd set from the left +* + DO 410 L = 1, KA - 1 + CALL DLARTV( NR, AB( L+1, J2-L ), INCA, + $ AB( L+2, J2-L ), INCA, WORK( N+J2 ), + $ WORK( J2 ), KA1 ) + 410 CONTINUE +* +* apply rotations in 2nd set from both sides to diagonal +* blocks +* + CALL DLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ), + $ INCA, WORK( N+J2 ), WORK( J2 ), KA1 ) +* + END IF +* +* start applying rotations in 2nd set from the right +* + DO 420 L = KA - 1, KB - K + 1, -1 + NRT = ( N-J2+L ) / KA1 + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA, + $ AB( KA1-L, J2+1 ), INCA, WORK( N+J2 ), + $ WORK( J2 ), KA1 ) + 420 CONTINUE +* + IF( WANTX ) THEN +* +* post-multiply X by product of rotations in 2nd set +* + DO 430 J = J2, J1, KA1 + CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1, + $ WORK( N+J ), WORK( J ) ) + 430 CONTINUE + END IF + 440 CONTINUE +* + DO 460 K = 1, KB - 1 + J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1 +* +* finish applying rotations in 1st set from the right +* + DO 450 L = KB - K, 1, -1 + NRT = ( N-J2+L ) / KA1 + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA, + $ AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ), + $ WORK( J2-M ), KA1 ) + 450 CONTINUE + 460 CONTINUE +* + IF( KB.GT.1 ) THEN + DO 470 J = N - 1, I - KB + 2*KA + 1, -1 + WORK( N+J-M ) = WORK( N+J-KA-M ) + WORK( J-M ) = WORK( J-KA-M ) + 470 CONTINUE + END IF +* + END IF +* + GO TO 10 +* + 480 CONTINUE +* +* **************************** Phase 2 ***************************** +* +* The logical structure of this phase is: +* +* UPDATE = .TRUE. +* DO I = 1, M +* use S(i) to update A and create a new bulge +* apply rotations to push all bulges KA positions upward +* END DO +* UPDATE = .FALSE. +* DO I = M - KA - 1, 2, -1 +* apply rotations to push all bulges KA positions upward +* END DO +* +* To avoid duplicating code, the two loops are merged. +* + UPDATE = .TRUE. + I = 0 + 490 CONTINUE + IF( UPDATE ) THEN + I = I + 1 + KBT = MIN( KB, M-I ) + I0 = I + 1 + I1 = MAX( 1, I-KA ) + I2 = I + KBT - KA1 + IF( I.GT.M ) THEN + UPDATE = .FALSE. + I = I - 1 + I0 = M + 1 + IF( KA.EQ.0 ) + $ RETURN + GO TO 490 + END IF + ELSE + I = I - KA + IF( I.LT.2 ) + $ RETURN + END IF +* + IF( I.LT.M-KBT ) THEN + NX = M + ELSE + NX = N + END IF +* + IF( UPPER ) THEN +* +* Transform A, working with the upper triangle +* + IF( UPDATE ) THEN +* +* Form inv(S(i))**T * A * inv(S(i)) +* + BII = BB( KB1, I ) + DO 500 J = I1, I + AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII + 500 CONTINUE + DO 510 J = I, MIN( N, I+KA ) + AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII + 510 CONTINUE + DO 540 K = I + 1, I + KBT + DO 520 J = K, I + KBT + AB( K-J+KA1, J ) = AB( K-J+KA1, J ) - + $ BB( I-J+KB1, J )*AB( I-K+KA1, K ) - + $ BB( I-K+KB1, K )*AB( I-J+KA1, J ) + + $ AB( KA1, I )*BB( I-J+KB1, J )* + $ BB( I-K+KB1, K ) + 520 CONTINUE + DO 530 J = I + KBT + 1, MIN( N, I+KA ) + AB( K-J+KA1, J ) = AB( K-J+KA1, J ) - + $ BB( I-K+KB1, K )*AB( I-J+KA1, J ) + 530 CONTINUE + 540 CONTINUE + DO 560 J = I1, I + DO 550 K = I + 1, MIN( J+KA, I+KBT ) + AB( J-K+KA1, K ) = AB( J-K+KA1, K ) - + $ BB( I-K+KB1, K )*AB( J-I+KA1, I ) + 550 CONTINUE + 560 CONTINUE +* + IF( WANTX ) THEN +* +* post-multiply X by inv(S(i)) +* + CALL DSCAL( NX, ONE / BII, X( 1, I ), 1 ) + IF( KBT.GT.0 ) + $ CALL DGER( NX, KBT, -ONE, X( 1, I ), 1, BB( KB, I+1 ), + $ LDBB-1, X( 1, I+1 ), LDX ) + END IF +* +* store a(i1,i) in RA1 for use in next loop over K +* + RA1 = AB( I1-I+KA1, I ) + END IF +* +* Generate and apply vectors of rotations to chase all the +* existing bulges KA positions up toward the top of the band +* + DO 610 K = 1, KB - 1 + IF( UPDATE ) THEN +* +* Determine the rotations which would annihilate the bulge +* which has in theory just been created +* + IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN +* +* generate rotation to annihilate a(i+k-ka-1,i) +* + CALL DLARTG( AB( K+1, I ), RA1, WORK( N+I+K-KA ), + $ WORK( I+K-KA ), RA ) +* +* create nonzero element a(i+k-ka-1,i+k) outside the +* band and store it in WORK(m-kb+i+k) +* + T = -BB( KB1-K, I+K )*RA1 + WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T - + $ WORK( I+K-KA )*AB( 1, I+K ) + AB( 1, I+K ) = WORK( I+K-KA )*T + + $ WORK( N+I+K-KA )*AB( 1, I+K ) + RA1 = RA + END IF + END IF + J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1 + NR = ( J2+KA-1 ) / KA1 + J1 = J2 - ( NR-1 )*KA1 + IF( UPDATE ) THEN + J2T = MIN( J2, I-2*KA+K-1 ) + ELSE + J2T = J2 + END IF + NRT = ( J2T+KA-1 ) / KA1 + DO 570 J = J1, J2T, KA1 +* +* create nonzero element a(j-1,j+ka) outside the band +* and store it in WORK(j) +* + WORK( J ) = WORK( J )*AB( 1, J+KA-1 ) + AB( 1, J+KA-1 ) = WORK( N+J )*AB( 1, J+KA-1 ) + 570 CONTINUE +* +* generate rotations in 1st set to annihilate elements which +* have been created outside the band +* + IF( NRT.GT.0 ) + $ CALL DLARGV( NRT, AB( 1, J1+KA ), INCA, WORK( J1 ), KA1, + $ WORK( N+J1 ), KA1 ) + IF( NR.GT.0 ) THEN +* +* apply rotations in 1st set from the left +* + DO 580 L = 1, KA - 1 + CALL DLARTV( NR, AB( KA1-L, J1+L ), INCA, + $ AB( KA-L, J1+L ), INCA, WORK( N+J1 ), + $ WORK( J1 ), KA1 ) + 580 CONTINUE +* +* apply rotations in 1st set from both sides to diagonal +* blocks +* + CALL DLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ), + $ AB( KA, J1 ), INCA, WORK( N+J1 ), + $ WORK( J1 ), KA1 ) +* + END IF +* +* start applying rotations in 1st set from the right +* + DO 590 L = KA - 1, KB - K + 1, -1 + NRT = ( J2+L-1 ) / KA1 + J1T = J2 - ( NRT-1 )*KA1 + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( L, J1T ), INCA, + $ AB( L+1, J1T-1 ), INCA, WORK( N+J1T ), + $ WORK( J1T ), KA1 ) + 590 CONTINUE +* + IF( WANTX ) THEN +* +* post-multiply X by product of rotations in 1st set +* + DO 600 J = J1, J2, KA1 + CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1, + $ WORK( N+J ), WORK( J ) ) + 600 CONTINUE + END IF + 610 CONTINUE +* + IF( UPDATE ) THEN + IF( I2.GT.0 .AND. KBT.GT.0 ) THEN +* +* create nonzero element a(i+kbt-ka-1,i+kbt) outside the +* band and store it in WORK(m-kb+i+kbt) +* + WORK( M-KB+I+KBT ) = -BB( KB1-KBT, I+KBT )*RA1 + END IF + END IF +* + DO 650 K = KB, 1, -1 + IF( UPDATE ) THEN + J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1 + ELSE + J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1 + END IF +* +* finish applying rotations in 2nd set from the right +* + DO 620 L = KB - K, 1, -1 + NRT = ( J2+KA+L-1 ) / KA1 + J1T = J2 - ( NRT-1 )*KA1 + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( L, J1T+KA ), INCA, + $ AB( L+1, J1T+KA-1 ), INCA, + $ WORK( N+M-KB+J1T+KA ), + $ WORK( M-KB+J1T+KA ), KA1 ) + 620 CONTINUE + NR = ( J2+KA-1 ) / KA1 + J1 = J2 - ( NR-1 )*KA1 + DO 630 J = J1, J2, KA1 + WORK( M-KB+J ) = WORK( M-KB+J+KA ) + WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA ) + 630 CONTINUE + DO 640 J = J1, J2, KA1 +* +* create nonzero element a(j-1,j+ka) outside the band +* and store it in WORK(m-kb+j) +* + WORK( M-KB+J ) = WORK( M-KB+J )*AB( 1, J+KA-1 ) + AB( 1, J+KA-1 ) = WORK( N+M-KB+J )*AB( 1, J+KA-1 ) + 640 CONTINUE + IF( UPDATE ) THEN + IF( I+K.GT.KA1 .AND. K.LE.KBT ) + $ WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K ) + END IF + 650 CONTINUE +* + DO 690 K = KB, 1, -1 + J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1 + NR = ( J2+KA-1 ) / KA1 + J1 = J2 - ( NR-1 )*KA1 + IF( NR.GT.0 ) THEN +* +* generate rotations in 2nd set to annihilate elements +* which have been created outside the band +* + CALL DLARGV( NR, AB( 1, J1+KA ), INCA, WORK( M-KB+J1 ), + $ KA1, WORK( N+M-KB+J1 ), KA1 ) +* +* apply rotations in 2nd set from the left +* + DO 660 L = 1, KA - 1 + CALL DLARTV( NR, AB( KA1-L, J1+L ), INCA, + $ AB( KA-L, J1+L ), INCA, + $ WORK( N+M-KB+J1 ), WORK( M-KB+J1 ), KA1 ) + 660 CONTINUE +* +* apply rotations in 2nd set from both sides to diagonal +* blocks +* + CALL DLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ), + $ AB( KA, J1 ), INCA, WORK( N+M-KB+J1 ), + $ WORK( M-KB+J1 ), KA1 ) +* + END IF +* +* start applying rotations in 2nd set from the right +* + DO 670 L = KA - 1, KB - K + 1, -1 + NRT = ( J2+L-1 ) / KA1 + J1T = J2 - ( NRT-1 )*KA1 + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( L, J1T ), INCA, + $ AB( L+1, J1T-1 ), INCA, + $ WORK( N+M-KB+J1T ), WORK( M-KB+J1T ), + $ KA1 ) + 670 CONTINUE +* + IF( WANTX ) THEN +* +* post-multiply X by product of rotations in 2nd set +* + DO 680 J = J1, J2, KA1 + CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1, + $ WORK( N+M-KB+J ), WORK( M-KB+J ) ) + 680 CONTINUE + END IF + 690 CONTINUE +* + DO 710 K = 1, KB - 1 + J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1 +* +* finish applying rotations in 1st set from the right +* + DO 700 L = KB - K, 1, -1 + NRT = ( J2+L-1 ) / KA1 + J1T = J2 - ( NRT-1 )*KA1 + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( L, J1T ), INCA, + $ AB( L+1, J1T-1 ), INCA, WORK( N+J1T ), + $ WORK( J1T ), KA1 ) + 700 CONTINUE + 710 CONTINUE +* + IF( KB.GT.1 ) THEN + DO 720 J = 2, MIN( I+KB, M ) - 2*KA - 1 + WORK( N+J ) = WORK( N+J+KA ) + WORK( J ) = WORK( J+KA ) + 720 CONTINUE + END IF +* + ELSE +* +* Transform A, working with the lower triangle +* + IF( UPDATE ) THEN +* +* Form inv(S(i))**T * A * inv(S(i)) +* + BII = BB( 1, I ) + DO 730 J = I1, I + AB( I-J+1, J ) = AB( I-J+1, J ) / BII + 730 CONTINUE + DO 740 J = I, MIN( N, I+KA ) + AB( J-I+1, I ) = AB( J-I+1, I ) / BII + 740 CONTINUE + DO 770 K = I + 1, I + KBT + DO 750 J = K, I + KBT + AB( J-K+1, K ) = AB( J-K+1, K ) - + $ BB( J-I+1, I )*AB( K-I+1, I ) - + $ BB( K-I+1, I )*AB( J-I+1, I ) + + $ AB( 1, I )*BB( J-I+1, I )* + $ BB( K-I+1, I ) + 750 CONTINUE + DO 760 J = I + KBT + 1, MIN( N, I+KA ) + AB( J-K+1, K ) = AB( J-K+1, K ) - + $ BB( K-I+1, I )*AB( J-I+1, I ) + 760 CONTINUE + 770 CONTINUE + DO 790 J = I1, I + DO 780 K = I + 1, MIN( J+KA, I+KBT ) + AB( K-J+1, J ) = AB( K-J+1, J ) - + $ BB( K-I+1, I )*AB( I-J+1, J ) + 780 CONTINUE + 790 CONTINUE +* + IF( WANTX ) THEN +* +* post-multiply X by inv(S(i)) +* + CALL DSCAL( NX, ONE / BII, X( 1, I ), 1 ) + IF( KBT.GT.0 ) + $ CALL DGER( NX, KBT, -ONE, X( 1, I ), 1, BB( 2, I ), 1, + $ X( 1, I+1 ), LDX ) + END IF +* +* store a(i,i1) in RA1 for use in next loop over K +* + RA1 = AB( I-I1+1, I1 ) + END IF +* +* Generate and apply vectors of rotations to chase all the +* existing bulges KA positions up toward the top of the band +* + DO 840 K = 1, KB - 1 + IF( UPDATE ) THEN +* +* Determine the rotations which would annihilate the bulge +* which has in theory just been created +* + IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN +* +* generate rotation to annihilate a(i,i+k-ka-1) +* + CALL DLARTG( AB( KA1-K, I+K-KA ), RA1, + $ WORK( N+I+K-KA ), WORK( I+K-KA ), RA ) +* +* create nonzero element a(i+k,i+k-ka-1) outside the +* band and store it in WORK(m-kb+i+k) +* + T = -BB( K+1, I )*RA1 + WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T - + $ WORK( I+K-KA )*AB( KA1, I+K-KA ) + AB( KA1, I+K-KA ) = WORK( I+K-KA )*T + + $ WORK( N+I+K-KA )*AB( KA1, I+K-KA ) + RA1 = RA + END IF + END IF + J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1 + NR = ( J2+KA-1 ) / KA1 + J1 = J2 - ( NR-1 )*KA1 + IF( UPDATE ) THEN + J2T = MIN( J2, I-2*KA+K-1 ) + ELSE + J2T = J2 + END IF + NRT = ( J2T+KA-1 ) / KA1 + DO 800 J = J1, J2T, KA1 +* +* create nonzero element a(j+ka,j-1) outside the band +* and store it in WORK(j) +* + WORK( J ) = WORK( J )*AB( KA1, J-1 ) + AB( KA1, J-1 ) = WORK( N+J )*AB( KA1, J-1 ) + 800 CONTINUE +* +* generate rotations in 1st set to annihilate elements which +* have been created outside the band +* + IF( NRT.GT.0 ) + $ CALL DLARGV( NRT, AB( KA1, J1 ), INCA, WORK( J1 ), KA1, + $ WORK( N+J1 ), KA1 ) + IF( NR.GT.0 ) THEN +* +* apply rotations in 1st set from the right +* + DO 810 L = 1, KA - 1 + CALL DLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ), + $ INCA, WORK( N+J1 ), WORK( J1 ), KA1 ) + 810 CONTINUE +* +* apply rotations in 1st set from both sides to diagonal +* blocks +* + CALL DLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ), + $ AB( 2, J1-1 ), INCA, WORK( N+J1 ), + $ WORK( J1 ), KA1 ) +* + END IF +* +* start applying rotations in 1st set from the left +* + DO 820 L = KA - 1, KB - K + 1, -1 + NRT = ( J2+L-1 ) / KA1 + J1T = J2 - ( NRT-1 )*KA1 + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA, + $ AB( KA1-L, J1T-KA1+L ), INCA, + $ WORK( N+J1T ), WORK( J1T ), KA1 ) + 820 CONTINUE +* + IF( WANTX ) THEN +* +* post-multiply X by product of rotations in 1st set +* + DO 830 J = J1, J2, KA1 + CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1, + $ WORK( N+J ), WORK( J ) ) + 830 CONTINUE + END IF + 840 CONTINUE +* + IF( UPDATE ) THEN + IF( I2.GT.0 .AND. KBT.GT.0 ) THEN +* +* create nonzero element a(i+kbt,i+kbt-ka-1) outside the +* band and store it in WORK(m-kb+i+kbt) +* + WORK( M-KB+I+KBT ) = -BB( KBT+1, I )*RA1 + END IF + END IF +* + DO 880 K = KB, 1, -1 + IF( UPDATE ) THEN + J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1 + ELSE + J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1 + END IF +* +* finish applying rotations in 2nd set from the left +* + DO 850 L = KB - K, 1, -1 + NRT = ( J2+KA+L-1 ) / KA1 + J1T = J2 - ( NRT-1 )*KA1 + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( KA1-L+1, J1T+L-1 ), INCA, + $ AB( KA1-L, J1T+L-1 ), INCA, + $ WORK( N+M-KB+J1T+KA ), + $ WORK( M-KB+J1T+KA ), KA1 ) + 850 CONTINUE + NR = ( J2+KA-1 ) / KA1 + J1 = J2 - ( NR-1 )*KA1 + DO 860 J = J1, J2, KA1 + WORK( M-KB+J ) = WORK( M-KB+J+KA ) + WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA ) + 860 CONTINUE + DO 870 J = J1, J2, KA1 +* +* create nonzero element a(j+ka,j-1) outside the band +* and store it in WORK(m-kb+j) +* + WORK( M-KB+J ) = WORK( M-KB+J )*AB( KA1, J-1 ) + AB( KA1, J-1 ) = WORK( N+M-KB+J )*AB( KA1, J-1 ) + 870 CONTINUE + IF( UPDATE ) THEN + IF( I+K.GT.KA1 .AND. K.LE.KBT ) + $ WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K ) + END IF + 880 CONTINUE +* + DO 920 K = KB, 1, -1 + J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1 + NR = ( J2+KA-1 ) / KA1 + J1 = J2 - ( NR-1 )*KA1 + IF( NR.GT.0 ) THEN +* +* generate rotations in 2nd set to annihilate elements +* which have been created outside the band +* + CALL DLARGV( NR, AB( KA1, J1 ), INCA, WORK( M-KB+J1 ), + $ KA1, WORK( N+M-KB+J1 ), KA1 ) +* +* apply rotations in 2nd set from the right +* + DO 890 L = 1, KA - 1 + CALL DLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ), + $ INCA, WORK( N+M-KB+J1 ), WORK( M-KB+J1 ), + $ KA1 ) + 890 CONTINUE +* +* apply rotations in 2nd set from both sides to diagonal +* blocks +* + CALL DLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ), + $ AB( 2, J1-1 ), INCA, WORK( N+M-KB+J1 ), + $ WORK( M-KB+J1 ), KA1 ) +* + END IF +* +* start applying rotations in 2nd set from the left +* + DO 900 L = KA - 1, KB - K + 1, -1 + NRT = ( J2+L-1 ) / KA1 + J1T = J2 - ( NRT-1 )*KA1 + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA, + $ AB( KA1-L, J1T-KA1+L ), INCA, + $ WORK( N+M-KB+J1T ), WORK( M-KB+J1T ), + $ KA1 ) + 900 CONTINUE +* + IF( WANTX ) THEN +* +* post-multiply X by product of rotations in 2nd set +* + DO 910 J = J1, J2, KA1 + CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1, + $ WORK( N+M-KB+J ), WORK( M-KB+J ) ) + 910 CONTINUE + END IF + 920 CONTINUE +* + DO 940 K = 1, KB - 1 + J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1 +* +* finish applying rotations in 1st set from the left +* + DO 930 L = KB - K, 1, -1 + NRT = ( J2+L-1 ) / KA1 + J1T = J2 - ( NRT-1 )*KA1 + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA, + $ AB( KA1-L, J1T-KA1+L ), INCA, + $ WORK( N+J1T ), WORK( J1T ), KA1 ) + 930 CONTINUE + 940 CONTINUE +* + IF( KB.GT.1 ) THEN + DO 950 J = 2, MIN( I+KB, M ) - 2*KA - 1 + WORK( N+J ) = WORK( N+J+KA ) + WORK( J ) = WORK( J+KA ) + 950 CONTINUE + END IF +* + END IF +* + GO TO 490 +* +* End of DSBGST +* + END diff --git a/math/lapack/src/main/fortran/dsbgv.f b/math/lapack/src/main/fortran/dsbgv.f new file mode 100644 index 0000000000..d82cdae93c --- /dev/null +++ b/math/lapack/src/main/fortran/dsbgv.f @@ -0,0 +1,280 @@ +*> \brief \b DSBGV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSBGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, +* LDZ, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), W( * ), +* $ WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSBGV computes all the eigenvalues, and optionally, the eigenvectors +*> of a real generalized symmetric-definite banded eigenproblem, of +*> the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric +*> and banded, and B is also positive definite. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangles of A and B are stored; +*> = 'L': Lower triangles of A and B are stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in] KA +*> \verbatim +*> KA is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KA >= 0. +*> \endverbatim +*> +*> \param[in] KB +*> \verbatim +*> KB is INTEGER +*> The number of superdiagonals of the matrix B if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KB >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first ka+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). +*> +*> On exit, the contents of AB are destroyed. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KA+1. +*> \endverbatim +*> +*> \param[in,out] BB +*> \verbatim +*> BB is DOUBLE PRECISION array, dimension (LDBB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix B, stored in the first kb+1 rows of the array. The +*> j-th column of B is stored in the j-th column of the array BB +*> as follows: +*> if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; +*> if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). +*> +*> On exit, the factor S from the split Cholesky factorization +*> B = S**T*S, as returned by DPBSTF. +*> \endverbatim +*> +*> \param[in] LDBB +*> \verbatim +*> LDBB is INTEGER +*> The leading dimension of the array BB. LDBB >= KB+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, N) +*> If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of +*> eigenvectors, with the i-th column of Z holding the +*> eigenvector associated with W(i). The eigenvectors are +*> normalized so that Z**T*B*Z = I. +*> If JOBZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, and i is: +*> <= N: the algorithm failed to converge: +*> i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF +*> returned INFO = i: B is not positive definite. +*> The factorization of B could not be completed and +*> no eigenvalues or eigenvectors were computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHEReigen +* +* ===================================================================== + SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, + $ LDZ, WORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), W( * ), + $ WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL UPPER, WANTZ + CHARACTER VECT + INTEGER IINFO, INDE, INDWRK +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DPBSTF, DSBGST, DSBTRD, DSTEQR, DSTERF, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + UPPER = LSAME( UPLO, 'U' ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KA.LT.0 ) THEN + INFO = -4 + ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN + INFO = -5 + ELSE IF( LDAB.LT.KA+1 ) THEN + INFO = -7 + ELSE IF( LDBB.LT.KB+1 ) THEN + INFO = -9 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -12 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSBGV ', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Form a split Cholesky factorization of B. +* + CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO ) + IF( INFO.NE.0 ) THEN + INFO = N + INFO + RETURN + END IF +* +* Transform problem to standard eigenvalue problem. +* + INDE = 1 + INDWRK = INDE + N + CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ, + $ WORK( INDWRK ), IINFO ) +* +* Reduce to tridiagonal form. +* + IF( WANTZ ) THEN + VECT = 'U' + ELSE + VECT = 'N' + END IF + CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ, + $ WORK( INDWRK ), IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE + CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ), + $ INFO ) + END IF + RETURN +* +* End of DSBGV +* + END diff --git a/math/lapack/src/main/fortran/dsbgvd.f b/math/lapack/src/main/fortran/dsbgvd.f new file mode 100644 index 0000000000..2a215fbf0e --- /dev/null +++ b/math/lapack/src/main/fortran/dsbgvd.f @@ -0,0 +1,372 @@ +*> \brief \b DSBGVD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSBGVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, +* Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), W( * ), +* $ WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSBGVD computes all the eigenvalues, and optionally, the eigenvectors +*> of a real generalized symmetric-definite banded eigenproblem, of the +*> form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and +*> banded, and B is also positive definite. If eigenvectors are +*> desired, it uses a divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangles of A and B are stored; +*> = 'L': Lower triangles of A and B are stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in] KA +*> \verbatim +*> KA is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KA >= 0. +*> \endverbatim +*> +*> \param[in] KB +*> \verbatim +*> KB is INTEGER +*> The number of superdiagonals of the matrix B if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KB >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first ka+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). +*> +*> On exit, the contents of AB are destroyed. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KA+1. +*> \endverbatim +*> +*> \param[in,out] BB +*> \verbatim +*> BB is DOUBLE PRECISION array, dimension (LDBB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix B, stored in the first kb+1 rows of the array. The +*> j-th column of B is stored in the j-th column of the array BB +*> as follows: +*> if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; +*> if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). +*> +*> On exit, the factor S from the split Cholesky factorization +*> B = S**T*S, as returned by DPBSTF. +*> \endverbatim +*> +*> \param[in] LDBB +*> \verbatim +*> LDBB is INTEGER +*> The leading dimension of the array BB. LDBB >= KB+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, N) +*> If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of +*> eigenvectors, with the i-th column of Z holding the +*> eigenvector associated with W(i). The eigenvectors are +*> normalized so Z**T*B*Z = I. +*> If JOBZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If N <= 1, LWORK >= 1. +*> If JOBZ = 'N' and N > 1, LWORK >= 2*N. +*> If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK and IWORK +*> arrays, returns these values as the first entries of the WORK +*> and IWORK arrays, and no error message related to LWORK or +*> LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If JOBZ = 'N' or N <= 1, LIWORK >= 1. +*> If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, and i is: +*> <= N: the algorithm failed to converge: +*> i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF +*> returned INFO = i: B is not positive definite. +*> The factorization of B could not be completed and +*> no eigenvalues or eigenvectors were computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHEReigen +* +*> \par Contributors: +* ================== +*> +*> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA +* +* ===================================================================== + SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, + $ Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), W( * ), + $ WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER, WANTZ + CHARACTER VECT + INTEGER IINFO, INDE, INDWK2, INDWRK, LIWMIN, LLWRK2, + $ LWMIN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DPBSTF, DSBGST, DSBTRD, DSTEDC, + $ DSTERF, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + INFO = 0 + IF( N.LE.1 ) THEN + LIWMIN = 1 + LWMIN = 1 + ELSE IF( WANTZ ) THEN + LIWMIN = 3 + 5*N + LWMIN = 1 + 5*N + 2*N**2 + ELSE + LIWMIN = 1 + LWMIN = 2*N + END IF +* + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KA.LT.0 ) THEN + INFO = -4 + ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN + INFO = -5 + ELSE IF( LDAB.LT.KA+1 ) THEN + INFO = -7 + ELSE IF( LDBB.LT.KB+1 ) THEN + INFO = -9 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -16 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSBGVD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Form a split Cholesky factorization of B. +* + CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO ) + IF( INFO.NE.0 ) THEN + INFO = N + INFO + RETURN + END IF +* +* Transform problem to standard eigenvalue problem. +* + INDE = 1 + INDWRK = INDE + N + INDWK2 = INDWRK + N*N + LLWRK2 = LWORK - INDWK2 + 1 + CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ, + $ WORK, IINFO ) +* +* Reduce to tridiagonal form. +* + IF( WANTZ ) THEN + VECT = 'U' + ELSE + VECT = 'N' + END IF + CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ, + $ WORK( INDWRK ), IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE + CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, + $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO ) + CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N, + $ ZERO, WORK( INDWK2 ), N ) + CALL DLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ ) + END IF +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of DSBGVD +* + END diff --git a/math/lapack/src/main/fortran/dsbgvx.f b/math/lapack/src/main/fortran/dsbgvx.f new file mode 100644 index 0000000000..eab5ebcbb1 --- /dev/null +++ b/math/lapack/src/main/fortran/dsbgvx.f @@ -0,0 +1,522 @@ +*> \brief \b DSBGVX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSBGVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, +* LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, +* LDZ, WORK, IWORK, IFAIL, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M, +* $ N +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ), +* $ W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSBGVX computes selected eigenvalues, and optionally, eigenvectors +*> of a real generalized symmetric-definite banded eigenproblem, of +*> the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric +*> and banded, and B is also positive definite. Eigenvalues and +*> eigenvectors can be selected by specifying either all eigenvalues, +*> a range of values or a range of indices for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangles of A and B are stored; +*> = 'L': Lower triangles of A and B are stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in] KA +*> \verbatim +*> KA is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KA >= 0. +*> \endverbatim +*> +*> \param[in] KB +*> \verbatim +*> KB is INTEGER +*> The number of superdiagonals of the matrix B if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KB >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first ka+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). +*> +*> On exit, the contents of AB are destroyed. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KA+1. +*> \endverbatim +*> +*> \param[in,out] BB +*> \verbatim +*> BB is DOUBLE PRECISION array, dimension (LDBB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix B, stored in the first kb+1 rows of the array. The +*> j-th column of B is stored in the j-th column of the array BB +*> as follows: +*> if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; +*> if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). +*> +*> On exit, the factor S from the split Cholesky factorization +*> B = S**T*S, as returned by DPBSTF. +*> \endverbatim +*> +*> \param[in] LDBB +*> \verbatim +*> LDBB is INTEGER +*> The leading dimension of the array BB. LDBB >= KB+1. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ, N) +*> If JOBZ = 'V', the n-by-n matrix used in the reduction of +*> A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x, +*> and consequently C to tridiagonal form. +*> If JOBZ = 'N', the array Q is not referenced. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. If JOBZ = 'N', +*> LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing A to tridiagonal form. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*DLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*DLAMCH('S'). +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, N) +*> If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of +*> eigenvectors, with the i-th column of Z holding the +*> eigenvector associated with W(i). The eigenvectors are +*> normalized so Z**T*B*Z = I. +*> If JOBZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (7*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (M) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvalues that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0 : successful exit +*> < 0 : if INFO = -i, the i-th argument had an illegal value +*> <= N: if INFO = i, then i eigenvectors failed to converge. +*> Their indices are stored in IFAIL. +*> > N : DPBSTF returned an error code; i.e., +*> if INFO = N + i, for 1 <= i <= N, then the leading +*> minor of order i of B is not positive definite. +*> The factorization of B could not be completed and +*> no eigenvalues or eigenvectors were computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHEReigen +* +*> \par Contributors: +* ================== +*> +*> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA +* +* ===================================================================== + SUBROUTINE DSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, + $ LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, + $ LDZ, WORK, IWORK, IFAIL, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M, + $ N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ), + $ W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, TEST, UPPER, VALEIG, WANTZ + CHARACTER ORDER, VECT + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, INDISP, + $ INDIWO, INDWRK, ITMP1, J, JJ, NSPLIT + DOUBLE PRECISION TMP1 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DLACPY, DPBSTF, DSBGST, DSBTRD, + $ DSTEBZ, DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( KA.LT.0 ) THEN + INFO = -5 + ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KA+1 ) THEN + INFO = -8 + ELSE IF( LDBB.LT.KB+1 ) THEN + INFO = -10 + ELSE IF( LDQ.LT.1 .OR. ( WANTZ .AND. LDQ.LT.N ) ) THEN + INFO = -12 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -14 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -16 + END IF + END IF + END IF + IF( INFO.EQ.0) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -21 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSBGVX', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) + $ RETURN +* +* Form a split Cholesky factorization of B. +* + CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO ) + IF( INFO.NE.0 ) THEN + INFO = N + INFO + RETURN + END IF +* +* Transform problem to standard eigenvalue problem. +* + CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, + $ WORK, IINFO ) +* +* Reduce symmetric band matrix to tridiagonal form. +* + INDD = 1 + INDE = INDD + N + INDWRK = INDE + N + IF( WANTZ ) THEN + VECT = 'U' + ELSE + VECT = 'N' + END IF + CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, WORK( INDD ), + $ WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO ) +* +* If all eigenvalues are desired and ABSTOL is less than or equal +* to zero, then call DSTERF or SSTEQR. If this fails for some +* eigenvalue, then try DSTEBZ. +* + TEST = .FALSE. + IF( INDEIG ) THEN + IF( IL.EQ.1 .AND. IU.EQ.N ) THEN + TEST = .TRUE. + END IF + END IF + IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN + CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) + INDEE = INDWRK + 2*N + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDEE ), INFO ) + ELSE + CALL DLACPY( 'A', N, N, Q, LDQ, Z, LDZ ) + CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, + $ WORK( INDWRK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 10 I = 1, N + IFAIL( I ) = 0 + 10 CONTINUE + END IF + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF +* +* Otherwise, call DSTEBZ and, if eigenvectors are desired, +* call DSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDIBL = 1 + INDISP = INDIBL + N + INDIWO = INDISP + N + CALL DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, + $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) +* +* Apply transformation matrix used in reduction to tridiagonal +* form to eigenvectors returned by DSTEIN. +* + DO 20 J = 1, M + CALL DCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 ) + CALL DGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO, + $ Z( 1, J ), 1 ) + 20 CONTINUE + END IF +* + 30 CONTINUE +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 50 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 40 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 40 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 50 CONTINUE + END IF +* + RETURN +* +* End of DSBGVX +* + END diff --git a/math/lapack/src/main/fortran/dsbtrd.f b/math/lapack/src/main/fortran/dsbtrd.f new file mode 100644 index 0000000000..9ea0c22082 --- /dev/null +++ b/math/lapack/src/main/fortran/dsbtrd.f @@ -0,0 +1,641 @@ +*> \brief \b DSBTRD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSBTRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, VECT +* INTEGER INFO, KD, LDAB, LDQ, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSBTRD reduces a real symmetric band matrix A to symmetric +*> tridiagonal form T by an orthogonal similarity transformation: +*> Q**T * A * Q = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] VECT +*> \verbatim +*> VECT is CHARACTER*1 +*> = 'N': do not form Q; +*> = 'V': form Q; +*> = 'U': update a matrix X, by forming X*Q. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> On exit, the diagonal elements of AB are overwritten by the +*> diagonal elements of the tridiagonal matrix T; if KD > 0, the +*> elements on the first superdiagonal (if UPLO = 'U') or the +*> first subdiagonal (if UPLO = 'L') are overwritten by the +*> off-diagonal elements of T; the rest of AB is overwritten by +*> values generated during the reduction. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The off-diagonal elements of the tridiagonal matrix T: +*> E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ,N) +*> On entry, if VECT = 'U', then Q must contain an N-by-N +*> matrix X; if VECT = 'N' or 'V', then Q need not be set. +*> +*> On exit: +*> if VECT = 'V', Q contains the N-by-N orthogonal matrix Q; +*> if VECT = 'U', Q contains the product X*Q; +*> if VECT = 'N', the array Q is not referenced. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. +*> LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Modified by Linda Kaufman, Bell Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, + $ WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO, VECT + INTEGER INFO, KD, LDAB, LDQ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL INITQ, UPPER, WANTQ + INTEGER I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J, + $ J1, J1END, J1INC, J2, JEND, JIN, JINC, K, KD1, + $ KDM1, KDN, L, LAST, LEND, NQ, NR, NRT + DOUBLE PRECISION TEMP +* .. +* .. External Subroutines .. + EXTERNAL DLAR2V, DLARGV, DLARTG, DLARTV, DLASET, DROT, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INITQ = LSAME( VECT, 'V' ) + WANTQ = INITQ .OR. LSAME( VECT, 'U' ) + UPPER = LSAME( UPLO, 'U' ) + KD1 = KD + 1 + KDM1 = KD - 1 + INCX = LDAB - 1 + IQEND = 1 +* + INFO = 0 + IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KD.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KD1 ) THEN + INFO = -6 + ELSE IF( LDQ.LT.MAX( 1, N ) .AND. WANTQ ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSBTRD', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Initialize Q to the unit matrix, if needed +* + IF( INITQ ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) +* +* Wherever possible, plane rotations are generated and applied in +* vector operations of length NR over the index set J1:J2:KD1. +* +* The cosines and sines of the plane rotations are stored in the +* arrays D and WORK. +* + INCA = KD1*LDAB + KDN = MIN( N-1, KD ) + IF( UPPER ) THEN +* + IF( KD.GT.1 ) THEN +* +* Reduce to tridiagonal form, working with upper triangle +* + NR = 0 + J1 = KDN + 2 + J2 = 1 +* + DO 90 I = 1, N - 2 +* +* Reduce i-th row of matrix to tridiagonal form +* + DO 80 K = KDN + 1, 2, -1 + J1 = J1 + KDN + J2 = J2 + KDN +* + IF( NR.GT.0 ) THEN +* +* generate plane rotations to annihilate nonzero +* elements which have been created outside the band +* + CALL DLARGV( NR, AB( 1, J1-1 ), INCA, WORK( J1 ), + $ KD1, D( J1 ), KD1 ) +* +* apply rotations from the right +* +* +* Dependent on the the number of diagonals either +* DLARTV or DROT is used +* + IF( NR.GE.2*KD-1 ) THEN + DO 10 L = 1, KD - 1 + CALL DLARTV( NR, AB( L+1, J1-1 ), INCA, + $ AB( L, J1 ), INCA, D( J1 ), + $ WORK( J1 ), KD1 ) + 10 CONTINUE +* + ELSE + JEND = J1 + ( NR-1 )*KD1 + DO 20 JINC = J1, JEND, KD1 + CALL DROT( KDM1, AB( 2, JINC-1 ), 1, + $ AB( 1, JINC ), 1, D( JINC ), + $ WORK( JINC ) ) + 20 CONTINUE + END IF + END IF +* +* + IF( K.GT.2 ) THEN + IF( K.LE.N-I+1 ) THEN +* +* generate plane rotation to annihilate a(i,i+k-1) +* within the band +* + CALL DLARTG( AB( KD-K+3, I+K-2 ), + $ AB( KD-K+2, I+K-1 ), D( I+K-1 ), + $ WORK( I+K-1 ), TEMP ) + AB( KD-K+3, I+K-2 ) = TEMP +* +* apply rotation from the right +* + CALL DROT( K-3, AB( KD-K+4, I+K-2 ), 1, + $ AB( KD-K+3, I+K-1 ), 1, D( I+K-1 ), + $ WORK( I+K-1 ) ) + END IF + NR = NR + 1 + J1 = J1 - KDN - 1 + END IF +* +* apply plane rotations from both sides to diagonal +* blocks +* + IF( NR.GT.0 ) + $ CALL DLAR2V( NR, AB( KD1, J1-1 ), AB( KD1, J1 ), + $ AB( KD, J1 ), INCA, D( J1 ), + $ WORK( J1 ), KD1 ) +* +* apply plane rotations from the left +* + IF( NR.GT.0 ) THEN + IF( 2*KD-1.LT.NR ) THEN +* +* Dependent on the the number of diagonals either +* DLARTV or DROT is used +* + DO 30 L = 1, KD - 1 + IF( J2+L.GT.N ) THEN + NRT = NR - 1 + ELSE + NRT = NR + END IF + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( KD-L, J1+L ), INCA, + $ AB( KD-L+1, J1+L ), INCA, + $ D( J1 ), WORK( J1 ), KD1 ) + 30 CONTINUE + ELSE + J1END = J1 + KD1*( NR-2 ) + IF( J1END.GE.J1 ) THEN + DO 40 JIN = J1, J1END, KD1 + CALL DROT( KD-1, AB( KD-1, JIN+1 ), INCX, + $ AB( KD, JIN+1 ), INCX, + $ D( JIN ), WORK( JIN ) ) + 40 CONTINUE + END IF + LEND = MIN( KDM1, N-J2 ) + LAST = J1END + KD1 + IF( LEND.GT.0 ) + $ CALL DROT( LEND, AB( KD-1, LAST+1 ), INCX, + $ AB( KD, LAST+1 ), INCX, D( LAST ), + $ WORK( LAST ) ) + END IF + END IF +* + IF( WANTQ ) THEN +* +* accumulate product of plane rotations in Q +* + IF( INITQ ) THEN +* +* take advantage of the fact that Q was +* initially the Identity matrix +* + IQEND = MAX( IQEND, J2 ) + I2 = MAX( 0, K-3 ) + IQAEND = 1 + I*KD + IF( K.EQ.2 ) + $ IQAEND = IQAEND + KD + IQAEND = MIN( IQAEND, IQEND ) + DO 50 J = J1, J2, KD1 + IBL = I - I2 / KDM1 + I2 = I2 + 1 + IQB = MAX( 1, J-IBL ) + NQ = 1 + IQAEND - IQB + IQAEND = MIN( IQAEND+KD, IQEND ) + CALL DROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ), + $ 1, D( J ), WORK( J ) ) + 50 CONTINUE + ELSE +* + DO 60 J = J1, J2, KD1 + CALL DROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1, + $ D( J ), WORK( J ) ) + 60 CONTINUE + END IF +* + END IF +* + IF( J2+KDN.GT.N ) THEN +* +* adjust J2 to keep within the bounds of the matrix +* + NR = NR - 1 + J2 = J2 - KDN - 1 + END IF +* + DO 70 J = J1, J2, KD1 +* +* create nonzero element a(j-1,j+kd) outside the band +* and store it in WORK +* + WORK( J+KD ) = WORK( J )*AB( 1, J+KD ) + AB( 1, J+KD ) = D( J )*AB( 1, J+KD ) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + END IF +* + IF( KD.GT.0 ) THEN +* +* copy off-diagonal elements to E +* + DO 100 I = 1, N - 1 + E( I ) = AB( KD, I+1 ) + 100 CONTINUE + ELSE +* +* set E to zero if original matrix was diagonal +* + DO 110 I = 1, N - 1 + E( I ) = ZERO + 110 CONTINUE + END IF +* +* copy diagonal elements to D +* + DO 120 I = 1, N + D( I ) = AB( KD1, I ) + 120 CONTINUE +* + ELSE +* + IF( KD.GT.1 ) THEN +* +* Reduce to tridiagonal form, working with lower triangle +* + NR = 0 + J1 = KDN + 2 + J2 = 1 +* + DO 210 I = 1, N - 2 +* +* Reduce i-th column of matrix to tridiagonal form +* + DO 200 K = KDN + 1, 2, -1 + J1 = J1 + KDN + J2 = J2 + KDN +* + IF( NR.GT.0 ) THEN +* +* generate plane rotations to annihilate nonzero +* elements which have been created outside the band +* + CALL DLARGV( NR, AB( KD1, J1-KD1 ), INCA, + $ WORK( J1 ), KD1, D( J1 ), KD1 ) +* +* apply plane rotations from one side +* +* +* Dependent on the the number of diagonals either +* DLARTV or DROT is used +* + IF( NR.GT.2*KD-1 ) THEN + DO 130 L = 1, KD - 1 + CALL DLARTV( NR, AB( KD1-L, J1-KD1+L ), INCA, + $ AB( KD1-L+1, J1-KD1+L ), INCA, + $ D( J1 ), WORK( J1 ), KD1 ) + 130 CONTINUE + ELSE + JEND = J1 + KD1*( NR-1 ) + DO 140 JINC = J1, JEND, KD1 + CALL DROT( KDM1, AB( KD, JINC-KD ), INCX, + $ AB( KD1, JINC-KD ), INCX, + $ D( JINC ), WORK( JINC ) ) + 140 CONTINUE + END IF +* + END IF +* + IF( K.GT.2 ) THEN + IF( K.LE.N-I+1 ) THEN +* +* generate plane rotation to annihilate a(i+k-1,i) +* within the band +* + CALL DLARTG( AB( K-1, I ), AB( K, I ), + $ D( I+K-1 ), WORK( I+K-1 ), TEMP ) + AB( K-1, I ) = TEMP +* +* apply rotation from the left +* + CALL DROT( K-3, AB( K-2, I+1 ), LDAB-1, + $ AB( K-1, I+1 ), LDAB-1, D( I+K-1 ), + $ WORK( I+K-1 ) ) + END IF + NR = NR + 1 + J1 = J1 - KDN - 1 + END IF +* +* apply plane rotations from both sides to diagonal +* blocks +* + IF( NR.GT.0 ) + $ CALL DLAR2V( NR, AB( 1, J1-1 ), AB( 1, J1 ), + $ AB( 2, J1-1 ), INCA, D( J1 ), + $ WORK( J1 ), KD1 ) +* +* apply plane rotations from the right +* +* +* Dependent on the the number of diagonals either +* DLARTV or DROT is used +* + IF( NR.GT.0 ) THEN + IF( NR.GT.2*KD-1 ) THEN + DO 150 L = 1, KD - 1 + IF( J2+L.GT.N ) THEN + NRT = NR - 1 + ELSE + NRT = NR + END IF + IF( NRT.GT.0 ) + $ CALL DLARTV( NRT, AB( L+2, J1-1 ), INCA, + $ AB( L+1, J1 ), INCA, D( J1 ), + $ WORK( J1 ), KD1 ) + 150 CONTINUE + ELSE + J1END = J1 + KD1*( NR-2 ) + IF( J1END.GE.J1 ) THEN + DO 160 J1INC = J1, J1END, KD1 + CALL DROT( KDM1, AB( 3, J1INC-1 ), 1, + $ AB( 2, J1INC ), 1, D( J1INC ), + $ WORK( J1INC ) ) + 160 CONTINUE + END IF + LEND = MIN( KDM1, N-J2 ) + LAST = J1END + KD1 + IF( LEND.GT.0 ) + $ CALL DROT( LEND, AB( 3, LAST-1 ), 1, + $ AB( 2, LAST ), 1, D( LAST ), + $ WORK( LAST ) ) + END IF + END IF +* +* +* + IF( WANTQ ) THEN +* +* accumulate product of plane rotations in Q +* + IF( INITQ ) THEN +* +* take advantage of the fact that Q was +* initially the Identity matrix +* + IQEND = MAX( IQEND, J2 ) + I2 = MAX( 0, K-3 ) + IQAEND = 1 + I*KD + IF( K.EQ.2 ) + $ IQAEND = IQAEND + KD + IQAEND = MIN( IQAEND, IQEND ) + DO 170 J = J1, J2, KD1 + IBL = I - I2 / KDM1 + I2 = I2 + 1 + IQB = MAX( 1, J-IBL ) + NQ = 1 + IQAEND - IQB + IQAEND = MIN( IQAEND+KD, IQEND ) + CALL DROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ), + $ 1, D( J ), WORK( J ) ) + 170 CONTINUE + ELSE +* + DO 180 J = J1, J2, KD1 + CALL DROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1, + $ D( J ), WORK( J ) ) + 180 CONTINUE + END IF + END IF +* + IF( J2+KDN.GT.N ) THEN +* +* adjust J2 to keep within the bounds of the matrix +* + NR = NR - 1 + J2 = J2 - KDN - 1 + END IF +* + DO 190 J = J1, J2, KD1 +* +* create nonzero element a(j+kd,j-1) outside the +* band and store it in WORK +* + WORK( J+KD ) = WORK( J )*AB( KD1, J ) + AB( KD1, J ) = D( J )*AB( KD1, J ) + 190 CONTINUE + 200 CONTINUE + 210 CONTINUE + END IF +* + IF( KD.GT.0 ) THEN +* +* copy off-diagonal elements to E +* + DO 220 I = 1, N - 1 + E( I ) = AB( 2, I ) + 220 CONTINUE + ELSE +* +* set E to zero if original matrix was diagonal +* + DO 230 I = 1, N - 1 + E( I ) = ZERO + 230 CONTINUE + END IF +* +* copy diagonal elements to D +* + DO 240 I = 1, N + D( I ) = AB( 1, I ) + 240 CONTINUE + END IF +* + RETURN +* +* End of DSBTRD +* + END diff --git a/math/lapack/src/main/fortran/dsfrk.f b/math/lapack/src/main/fortran/dsfrk.f new file mode 100644 index 0000000000..1fd1763e72 --- /dev/null +++ b/math/lapack/src/main/fortran/dsfrk.f @@ -0,0 +1,544 @@ +*> \brief \b DSFRK performs a symmetric rank-k operation for matrix in RFP format. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSFRK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, +* C ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA, BETA +* INTEGER K, LDA, N +* CHARACTER TRANS, TRANSR, UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Level 3 BLAS like routine for C in RFP Format. +*> +*> DSFRK performs one of the symmetric rank--k operations +*> +*> C := alpha*A*A**T + beta*C, +*> +*> or +*> +*> C := alpha*A**T*A + beta*C, +*> +*> where alpha and beta are real scalars, C is an n--by--n symmetric +*> matrix and A is an n--by--k matrix in the first case and a k--by--n +*> matrix in the second case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSR +*> \verbatim +*> TRANSR is CHARACTER*1 +*> = 'N': The Normal Form of RFP A is stored; +*> = 'T': The Transpose Form of RFP A is stored. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array C is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of C +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of C +*> is to be referenced. +*> +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C. +*> +*> TRANS = 'T' or 't' C := alpha*A**T*A + beta*C. +*> +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix C. N must be +*> at least zero. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with TRANS = 'N' or 'n', K specifies the number +*> of columns of the matrix A, and on entry with TRANS = 'T' +*> or 't', K specifies the number of rows of the matrix A. K +*> must be at least zero. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> On entry, ALPHA specifies the scalar alpha. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,ka) +*> where KA +*> is K when TRANS = 'N' or 'n', and is N otherwise. Before +*> entry with TRANS = 'N' or 'n', the leading N--by--K part of +*> the array A must contain the matrix A, otherwise the leading +*> K--by--N part of the array A must contain the matrix A. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDA must be at least max( 1, n ), otherwise LDA must +*> be at least max( 1, k ). +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION +*> On entry, BETA specifies the scalar beta. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (NT) +*> NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP +*> Format. RFP Format is described by TRANSR, UPLO and N. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, + $ C ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER K, LDA, N + CHARACTER TRANS, TRANSR, UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NORMALTRANSR, NISODD, NOTRANS + INTEGER INFO, NROWA, J, NK, N1, N2 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DGEMM, DSYRK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + NOTRANS = LSAME( TRANS, 'N' ) +* + IF( NOTRANS ) THEN + NROWA = N + ELSE + NROWA = K + END IF +* + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOTRANS .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSFRK ', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* +* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not +* done (it is in DSYRK for example) and left in the general case. +* + IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. + $ ( BETA.EQ.ONE ) ) )RETURN +* + IF( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ZERO ) ) THEN + DO J = 1, ( ( N*( N+1 ) ) / 2 ) + C( J ) = ZERO + END DO + RETURN + END IF +* +* C is N-by-N. +* If N is odd, set NISODD = .TRUE., and N1 and N2. +* If N is even, NISODD = .FALSE., and NK. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + NISODD = .FALSE. + NK = N / 2 + ELSE + NISODD = .TRUE. + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF + END IF +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' +* + CALL DSYRK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + $ BETA, C( 1 ), N ) + CALL DSYRK( 'U', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, + $ BETA, C( N+1 ), N ) + CALL DGEMM( 'N', 'T', N2, N1, K, ALPHA, A( N1+1, 1 ), + $ LDA, A( 1, 1 ), LDA, BETA, C( N1+1 ), N ) +* + ELSE +* +* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' +* + CALL DSYRK( 'L', 'T', N1, K, ALPHA, A( 1, 1 ), LDA, + $ BETA, C( 1 ), N ) + CALL DSYRK( 'U', 'T', N2, K, ALPHA, A( 1, N1+1 ), LDA, + $ BETA, C( N+1 ), N ) + CALL DGEMM( 'T', 'N', N2, N1, K, ALPHA, A( 1, N1+1 ), + $ LDA, A( 1, 1 ), LDA, BETA, C( N1+1 ), N ) +* + END IF +* + ELSE +* +* N is odd, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' +* + CALL DSYRK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + $ BETA, C( N2+1 ), N ) + CALL DSYRK( 'U', 'N', N2, K, ALPHA, A( N2, 1 ), LDA, + $ BETA, C( N1+1 ), N ) + CALL DGEMM( 'N', 'T', N1, N2, K, ALPHA, A( 1, 1 ), + $ LDA, A( N2, 1 ), LDA, BETA, C( 1 ), N ) +* + ELSE +* +* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' +* + CALL DSYRK( 'L', 'T', N1, K, ALPHA, A( 1, 1 ), LDA, + $ BETA, C( N2+1 ), N ) + CALL DSYRK( 'U', 'T', N2, K, ALPHA, A( 1, N2 ), LDA, + $ BETA, C( N1+1 ), N ) + CALL DGEMM( 'T', 'N', N1, N2, K, ALPHA, A( 1, 1 ), + $ LDA, A( 1, N2 ), LDA, BETA, C( 1 ), N ) +* + END IF +* + END IF +* + ELSE +* +* N is odd, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' +* + CALL DSYRK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + $ BETA, C( 1 ), N1 ) + CALL DSYRK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, + $ BETA, C( 2 ), N1 ) + CALL DGEMM( 'N', 'T', N1, N2, K, ALPHA, A( 1, 1 ), + $ LDA, A( N1+1, 1 ), LDA, BETA, + $ C( N1*N1+1 ), N1 ) +* + ELSE +* +* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' +* + CALL DSYRK( 'U', 'T', N1, K, ALPHA, A( 1, 1 ), LDA, + $ BETA, C( 1 ), N1 ) + CALL DSYRK( 'L', 'T', N2, K, ALPHA, A( 1, N1+1 ), LDA, + $ BETA, C( 2 ), N1 ) + CALL DGEMM( 'T', 'N', N1, N2, K, ALPHA, A( 1, 1 ), + $ LDA, A( 1, N1+1 ), LDA, BETA, + $ C( N1*N1+1 ), N1 ) +* + END IF +* + ELSE +* +* N is odd, TRANSR = 'T', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' +* + CALL DSYRK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + $ BETA, C( N2*N2+1 ), N2 ) + CALL DSYRK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, + $ BETA, C( N1*N2+1 ), N2 ) + CALL DGEMM( 'N', 'T', N2, N1, K, ALPHA, A( N1+1, 1 ), + $ LDA, A( 1, 1 ), LDA, BETA, C( 1 ), N2 ) +* + ELSE +* +* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' +* + CALL DSYRK( 'U', 'T', N1, K, ALPHA, A( 1, 1 ), LDA, + $ BETA, C( N2*N2+1 ), N2 ) + CALL DSYRK( 'L', 'T', N2, K, ALPHA, A( 1, N1+1 ), LDA, + $ BETA, C( N1*N2+1 ), N2 ) + CALL DGEMM( 'T', 'N', N2, N1, K, ALPHA, A( 1, N1+1 ), + $ LDA, A( 1, 1 ), LDA, BETA, C( 1 ), N2 ) +* + END IF +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' +* + CALL DSYRK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + $ BETA, C( 2 ), N+1 ) + CALL DSYRK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + $ BETA, C( 1 ), N+1 ) + CALL DGEMM( 'N', 'T', NK, NK, K, ALPHA, A( NK+1, 1 ), + $ LDA, A( 1, 1 ), LDA, BETA, C( NK+2 ), + $ N+1 ) +* + ELSE +* +* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' +* + CALL DSYRK( 'L', 'T', NK, K, ALPHA, A( 1, 1 ), LDA, + $ BETA, C( 2 ), N+1 ) + CALL DSYRK( 'U', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA, + $ BETA, C( 1 ), N+1 ) + CALL DGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, NK+1 ), + $ LDA, A( 1, 1 ), LDA, BETA, C( NK+2 ), + $ N+1 ) +* + END IF +* + ELSE +* +* N is even, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' +* + CALL DSYRK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + $ BETA, C( NK+2 ), N+1 ) + CALL DSYRK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + $ BETA, C( NK+1 ), N+1 ) + CALL DGEMM( 'N', 'T', NK, NK, K, ALPHA, A( 1, 1 ), + $ LDA, A( NK+1, 1 ), LDA, BETA, C( 1 ), + $ N+1 ) +* + ELSE +* +* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' +* + CALL DSYRK( 'L', 'T', NK, K, ALPHA, A( 1, 1 ), LDA, + $ BETA, C( NK+2 ), N+1 ) + CALL DSYRK( 'U', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA, + $ BETA, C( NK+1 ), N+1 ) + CALL DGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, 1 ), + $ LDA, A( 1, NK+1 ), LDA, BETA, C( 1 ), + $ N+1 ) +* + END IF +* + END IF +* + ELSE +* +* N is even, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' +* + CALL DSYRK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + $ BETA, C( NK+1 ), NK ) + CALL DSYRK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + $ BETA, C( 1 ), NK ) + CALL DGEMM( 'N', 'T', NK, NK, K, ALPHA, A( 1, 1 ), + $ LDA, A( NK+1, 1 ), LDA, BETA, + $ C( ( ( NK+1 )*NK )+1 ), NK ) +* + ELSE +* +* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' +* + CALL DSYRK( 'U', 'T', NK, K, ALPHA, A( 1, 1 ), LDA, + $ BETA, C( NK+1 ), NK ) + CALL DSYRK( 'L', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA, + $ BETA, C( 1 ), NK ) + CALL DGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, 1 ), + $ LDA, A( 1, NK+1 ), LDA, BETA, + $ C( ( ( NK+1 )*NK )+1 ), NK ) +* + END IF +* + ELSE +* +* N is even, TRANSR = 'T', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' +* + CALL DSYRK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + $ BETA, C( NK*( NK+1 )+1 ), NK ) + CALL DSYRK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + $ BETA, C( NK*NK+1 ), NK ) + CALL DGEMM( 'N', 'T', NK, NK, K, ALPHA, A( NK+1, 1 ), + $ LDA, A( 1, 1 ), LDA, BETA, C( 1 ), NK ) +* + ELSE +* +* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' +* + CALL DSYRK( 'U', 'T', NK, K, ALPHA, A( 1, 1 ), LDA, + $ BETA, C( NK*( NK+1 )+1 ), NK ) + CALL DSYRK( 'L', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA, + $ BETA, C( NK*NK+1 ), NK ) + CALL DGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, NK+1 ), + $ LDA, A( 1, 1 ), LDA, BETA, C( 1 ), NK ) +* + END IF +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of DSFRK +* + END diff --git a/math/lapack/src/main/fortran/dsgesv.f b/math/lapack/src/main/fortran/dsgesv.f new file mode 100644 index 0000000000..e867b974d1 --- /dev/null +++ b/math/lapack/src/main/fortran/dsgesv.f @@ -0,0 +1,433 @@ +*> \brief DSGESV computes the solution to system of linear equations A * X = B for GE matrices (mixed precision with iterative refinement) +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSGESV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, +* SWORK, ITER, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL SWORK( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( N, * ), +* $ X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSGESV computes the solution to a real system of linear equations +*> A * X = B, +*> where A is an N-by-N matrix and X and B are N-by-NRHS matrices. +*> +*> DSGESV first attempts to factorize the matrix in SINGLE PRECISION +*> and use this factorization within an iterative refinement procedure +*> to produce a solution with DOUBLE PRECISION normwise backward error +*> quality (see below). If the approach fails the method switches to a +*> DOUBLE PRECISION factorization and solve. +*> +*> The iterative refinement is not going to be a winning strategy if +*> the ratio SINGLE PRECISION performance over DOUBLE PRECISION +*> performance is too small. A reasonable strategy should take the +*> number of right-hand sides and the size of the matrix into account. +*> This might be done with a call to ILAENV in the future. Up to now, we +*> always try iterative refinement. +*> +*> The iterative refinement process is stopped if +*> ITER > ITERMAX +*> or for all the RHS we have: +*> RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX +*> where +*> o ITER is the number of the current iteration in the iterative +*> refinement process +*> o RNRM is the infinity-norm of the residual +*> o XNRM is the infinity-norm of the solution +*> o ANRM is the infinity-operator-norm of the matrix A +*> o EPS is the machine epsilon returned by DLAMCH('Epsilon') +*> The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 +*> respectively. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, +*> dimension (LDA,N) +*> On entry, the N-by-N coefficient matrix A. +*> On exit, if iterative refinement has been successfully used +*> (INFO.EQ.0 and ITER.GE.0, see description below), then A is +*> unchanged, if double precision factorization has been used +*> (INFO.EQ.0 and ITER.LT.0, see description below), then the +*> array A contains the factors L and U from the factorization +*> A = P*L*U; the unit diagonal elements of L are not stored. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices that define the permutation matrix P; +*> row i of the matrix was interchanged with row IPIV(i). +*> Corresponds either to the single precision factorization +*> (if INFO.EQ.0 and ITER.GE.0) or the double precision +*> factorization (if INFO.EQ.0 and ITER.LT.0). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The N-by-NRHS right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> If INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N,NRHS) +*> This array is used to hold the residual vectors. +*> \endverbatim +*> +*> \param[out] SWORK +*> \verbatim +*> SWORK is REAL array, dimension (N*(N+NRHS)) +*> This array is used to use the single precision matrix and the +*> right-hand sides or solutions in single precision. +*> \endverbatim +*> +*> \param[out] ITER +*> \verbatim +*> ITER is INTEGER +*> < 0: iterative refinement has failed, double precision +*> factorization has been performed +*> -1 : the routine fell back to full precision for +*> implementation- or machine-specific reasons +*> -2 : narrowing the precision induced an overflow, +*> the routine fell back to full precision +*> -3 : failure of SGETRF +*> -31: stop the iterative refinement after the 30th +*> iterations +*> > 0: iterative refinement has been successfully used. +*> Returns the number of iterations +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, U(i,i) computed in DOUBLE PRECISION is +*> exactly zero. The factorization has been completed, +*> but the factor U is exactly singular, so the solution +*> could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleGEsolve +* +* ===================================================================== + SUBROUTINE DSGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, + $ SWORK, ITER, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL SWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( N, * ), + $ X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + LOGICAL DOITREF + PARAMETER ( DOITREF = .TRUE. ) +* + INTEGER ITERMAX + PARAMETER ( ITERMAX = 30 ) +* + DOUBLE PRECISION BWDMAX + PARAMETER ( BWDMAX = 1.0E+00 ) +* + DOUBLE PRECISION NEGONE, ONE + PARAMETER ( NEGONE = -1.0D+0, ONE = 1.0D+0 ) +* +* .. Local Scalars .. + INTEGER I, IITER, PTSA, PTSX + DOUBLE PRECISION ANRM, CTE, EPS, RNRM, XNRM +* +* .. External Subroutines .. + EXTERNAL DAXPY, DGEMM, DLACPY, DLAG2S, SLAG2D, SGETRF, + $ SGETRS, XERBLA +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL IDAMAX, DLAMCH, DLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 + ITER = 0 +* +* Test the input parameters. +* + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSGESV', -INFO ) + RETURN + END IF +* +* Quick return if (N.EQ.0). +* + IF( N.EQ.0 ) + $ RETURN +* +* Skip single precision iterative refinement if a priori slower +* than double precision factorization. +* + IF( .NOT.DOITREF ) THEN + ITER = -1 + GO TO 40 + END IF +* +* Compute some constants. +* + ANRM = DLANGE( 'I', N, N, A, LDA, WORK ) + EPS = DLAMCH( 'Epsilon' ) + CTE = ANRM*EPS*SQRT( DBLE( N ) )*BWDMAX +* +* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. +* + PTSA = 1 + PTSX = PTSA + N*N +* +* Convert B from double precision to single precision and store the +* result in SX. +* + CALL DLAG2S( N, NRHS, B, LDB, SWORK( PTSX ), N, INFO ) +* + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 + END IF +* +* Convert A from double precision to single precision and store the +* result in SA. +* + CALL DLAG2S( N, N, A, LDA, SWORK( PTSA ), N, INFO ) +* + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 + END IF +* +* Compute the LU factorization of SA. +* + CALL SGETRF( N, N, SWORK( PTSA ), N, IPIV, INFO ) +* + IF( INFO.NE.0 ) THEN + ITER = -3 + GO TO 40 + END IF +* +* Solve the system SA*SX = SB. +* + CALL SGETRS( 'No transpose', N, NRHS, SWORK( PTSA ), N, IPIV, + $ SWORK( PTSX ), N, INFO ) +* +* Convert SX back to double precision +* + CALL SLAG2D( N, NRHS, SWORK( PTSX ), N, X, LDX, INFO ) +* +* Compute R = B - AX (R is WORK). +* + CALL DLACPY( 'All', N, NRHS, B, LDB, WORK, N ) +* + CALL DGEMM( 'No Transpose', 'No Transpose', N, NRHS, N, NEGONE, A, + $ LDA, X, LDX, ONE, WORK, N ) +* +* Check whether the NRHS normwise backward errors satisfy the +* stopping criterion. If yes, set ITER=0 and return. +* + DO I = 1, NRHS + XNRM = ABS( X( IDAMAX( N, X( 1, I ), 1 ), I ) ) + RNRM = ABS( WORK( IDAMAX( N, WORK( 1, I ), 1 ), I ) ) + IF( RNRM.GT.XNRM*CTE ) + $ GO TO 10 + END DO +* +* If we are here, the NRHS normwise backward errors satisfy the +* stopping criterion. We are good to exit. +* + ITER = 0 + RETURN +* + 10 CONTINUE +* + DO 30 IITER = 1, ITERMAX +* +* Convert R (in WORK) from double precision to single precision +* and store the result in SX. +* + CALL DLAG2S( N, NRHS, WORK, N, SWORK( PTSX ), N, INFO ) +* + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 + END IF +* +* Solve the system SA*SX = SR. +* + CALL SGETRS( 'No transpose', N, NRHS, SWORK( PTSA ), N, IPIV, + $ SWORK( PTSX ), N, INFO ) +* +* Convert SX back to double precision and update the current +* iterate. +* + CALL SLAG2D( N, NRHS, SWORK( PTSX ), N, WORK, N, INFO ) +* + DO I = 1, NRHS + CALL DAXPY( N, ONE, WORK( 1, I ), 1, X( 1, I ), 1 ) + END DO +* +* Compute R = B - AX (R is WORK). +* + CALL DLACPY( 'All', N, NRHS, B, LDB, WORK, N ) +* + CALL DGEMM( 'No Transpose', 'No Transpose', N, NRHS, N, NEGONE, + $ A, LDA, X, LDX, ONE, WORK, N ) +* +* Check whether the NRHS normwise backward errors satisfy the +* stopping criterion. If yes, set ITER=IITER>0 and return. +* + DO I = 1, NRHS + XNRM = ABS( X( IDAMAX( N, X( 1, I ), 1 ), I ) ) + RNRM = ABS( WORK( IDAMAX( N, WORK( 1, I ), 1 ), I ) ) + IF( RNRM.GT.XNRM*CTE ) + $ GO TO 20 + END DO +* +* If we are here, the NRHS normwise backward errors satisfy the +* stopping criterion, we are good to exit. +* + ITER = IITER +* + RETURN +* + 20 CONTINUE +* + 30 CONTINUE +* +* If we are at this place of the code, this is because we have +* performed ITER=ITERMAX iterations and never satisified the +* stopping criterion, set up the ITER flag accordingly and follow up +* on double precision routine. +* + ITER = -ITERMAX - 1 +* + 40 CONTINUE +* +* Single-precision iterative refinement failed to converge to a +* satisfactory solution, so we resort to double precision. +* + CALL DGETRF( N, N, A, LDA, IPIV, INFO ) +* + IF( INFO.NE.0 ) + $ RETURN +* + CALL DLACPY( 'All', N, NRHS, B, LDB, X, LDX ) + CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, X, LDX, + $ INFO ) +* + RETURN +* +* End of DSGESV. +* + END diff --git a/math/lapack/src/main/fortran/dspcon.f b/math/lapack/src/main/fortran/dspcon.f new file mode 100644 index 0000000000..b422f844c1 --- /dev/null +++ b/math/lapack/src/main/fortran/dspcon.f @@ -0,0 +1,238 @@ +*> \brief \b DSPCON +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION AP( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPCON estimates the reciprocal of the condition number (in the +*> 1-norm) of a real symmetric packed matrix A using the factorization +*> A = U*D*U**T or A = L*D*L**T computed by DSPTRF. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by DSPTRF, stored as a +*> packed triangular matrix. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSPTRF. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is DOUBLE PRECISION +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION AP( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IP, KASE + DOUBLE PRECISION AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DSPTRS, XERBLA +* .. +* .. 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( ANORM.LT.ZERO ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPCON', -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 +* + IP = N*( N+1 ) / 2 + DO 10 I = N, 1, -1 + IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO ) + $ RETURN + IP = IP - I + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + IP = 1 + DO 20 I = 1, N + IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO ) + $ RETURN + IP = IP + N - I + 1 + 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**T) or inv(U*D*U**T). +* + CALL DSPTRS( UPLO, N, 1, AP, 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 DSPCON +* + END diff --git a/math/lapack/src/main/fortran/dspev.f b/math/lapack/src/main/fortran/dspev.f new file mode 100644 index 0000000000..f3142791ef --- /dev/null +++ b/math/lapack/src/main/fortran/dspev.f @@ -0,0 +1,262 @@ +*> \brief DSPEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSPEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPEV computes all the eigenvalues and, optionally, eigenvectors of a +*> real symmetric matrix A in packed storage. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is 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. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is 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. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHEReigen +* +* ===================================================================== + SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dspevd.f b/math/lapack/src/main/fortran/dspevd.f new file mode 100644 index 0000000000..234d03fed8 --- /dev/null +++ b/math/lapack/src/main/fortran/dspevd.f @@ -0,0 +1,338 @@ +*> \brief DSPEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSPEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, +* IWORK, LIWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPEVD computes all the eigenvalues and, optionally, eigenvectors +*> of a real symmetric matrix A in packed storage. If eigenvectors are +*> desired, it uses a divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is 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. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is 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. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, +*> dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the required LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If N <= 1, LWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LWORK must be at least 2*N. +*> If JOBZ = 'V' and N > 1, LWORK must be at least +*> 1 + 6*N + N**2. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the required sizes of the WORK and IWORK +*> arrays, returns these values as the first entries of the WORK +*> and IWORK arrays, and no error message related to LWORK or +*> LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the required LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. +*> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the required sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHEReigen +* +* ===================================================================== + SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, + $ IWORK, LIWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, WANTZ + INTEGER IINFO, INDE, INDTAU, INDWRK, ISCALE, LIWMIN, + $ LLWORK, LWMIN + 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 DOPMTR, DSCAL, DSPTRD, DSTEDC, DSTERF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + 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.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LIWMIN = 1 + LWMIN = 1 + ELSE + IF( WANTZ ) THEN + LIWMIN = 3 + 5*N + LWMIN = 1 + 6*N + N**2 + ELSE + LIWMIN = 1 + LWMIN = 2*N + END IF + END IF + IWORK( 1 ) = LIWMIN + WORK( 1 ) = LWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -9 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPEVD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + 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 +* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the +* tridiagonal matrix, then call DOPMTR to multiply it by the +* Householder transformations represented in AP. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE + INDWRK = INDTAU + N + LLWORK = LWORK - INDWRK + 1 + CALL DSTEDC( 'I', N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ), + $ LLWORK, IWORK, LIWORK, INFO ) + CALL DOPMTR( 'L', UPLO, 'N', N, N, AP, WORK( INDTAU ), Z, LDZ, + $ WORK( INDWRK ), IINFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( N, ONE / SIGMA, W, 1 ) +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN + RETURN +* +* End of DSPEVD +* + END diff --git a/math/lapack/src/main/fortran/dspevx.f b/math/lapack/src/main/fortran/dspevx.f new file mode 100644 index 0000000000..d66dc18efb --- /dev/null +++ b/math/lapack/src/main/fortran/dspevx.f @@ -0,0 +1,496 @@ +*> \brief DSPEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSPEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, +* ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, LDZ, M, N +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPEVX computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric matrix A in packed storage. Eigenvalues/vectors +*> can be selected by specifying either a range of values or a range of +*> indices for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found; +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found; +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is 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. +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing AP to tridiagonal form. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*DLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*DLAMCH('S'). +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the selected eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If an eigenvector fails to converge, then that column of Z +*> contains the latest approximation to the eigenvector, and the +*> index of the eigenvector is returned in IFAIL. +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (8*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (N) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvectors that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, then i eigenvectors failed to converge. +*> Their indices are stored in array IFAIL. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHEReigen +* +* ===================================================================== + SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, + $ ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, + $ INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, LDZ, M, N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ + CHARACTER ORDER + INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + $ INDISP, INDIWO, INDTAU, INDWRK, ISCALE, ITMP1, + $ J, JJ, NSPLIT + DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSP + EXTERNAL LSAME, DLAMCH, DLANSP +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DOPGTR, DOPMTR, DSCAL, DSPTRD, DSTEBZ, + $ DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) + $ THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -7 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -9 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) + $ INFO = -14 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPEVX', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = AP( 1 ) + ELSE + IF( VL.LT.AP( 1 ) .AND. VU.GE.AP( 1 ) ) THEN + M = 1 + W( 1 ) = AP( 1 ) + END IF + END IF + 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 = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF( VALEIG ) THEN + VLL = VL + VUU = VU + ELSE + VLL = ZERO + VUU = ZERO + END IF + ANRM = DLANSP( 'M', UPLO, N, AP, WORK ) + 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 ) + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF +* +* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. +* + INDTAU = 1 + INDE = INDTAU + N + INDD = INDE + N + INDWRK = INDD + N + CALL DSPTRD( UPLO, N, AP, WORK( INDD ), WORK( INDE ), + $ WORK( INDTAU ), IINFO ) +* +* If all eigenvalues are desired and ABSTOL is less than or equal +* to zero, then call DSTERF or DOPGTR and SSTEQR. If this fails +* for some eigenvalue, then try DSTEBZ. +* + TEST = .FALSE. + IF (INDEIG) THEN + IF (IL.EQ.1 .AND. IU.EQ.N) THEN + TEST = .TRUE. + END IF + END IF + IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN + CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) + INDEE = INDWRK + 2*N + IF( .NOT.WANTZ ) THEN + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTERF( N, W, WORK( INDEE ), INFO ) + ELSE + CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ, + $ WORK( INDWRK ), IINFO ) + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, + $ WORK( INDWRK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 10 I = 1, N + IFAIL( I ) = 0 + 10 CONTINUE + END IF + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 20 + END IF + INFO = 0 + END IF +* +* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDIBL = 1 + INDISP = INDIBL + N + INDIWO = INDISP + N + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by DSTEIN. +* + CALL DOPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ, + $ WORK( INDWRK ), IINFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 20 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 40 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 30 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 30 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 40 CONTINUE + END IF +* + RETURN +* +* End of DSPEVX +* + END diff --git a/math/lapack/src/main/fortran/dspgst.f b/math/lapack/src/main/fortran/dspgst.f new file mode 100644 index 0000000000..59cda68b43 --- /dev/null +++ b/math/lapack/src/main/fortran/dspgst.f @@ -0,0 +1,274 @@ +*> \brief \b DSPGST +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSPGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, ITYPE, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ), BP( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is 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. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is 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. +*> \endverbatim +*> +*> \param[in] BP +*> \verbatim +*> BP is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, ITYPE, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), BP( * ) +* .. +* +* ===================================================================== +* +* .. 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**T)*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**T) +* +* 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**T +* +* 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**T *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/math/lapack/src/main/fortran/dspgv.f b/math/lapack/src/main/fortran/dspgv.f new file mode 100644 index 0000000000..085e96fe1f --- /dev/null +++ b/math/lapack/src/main/fortran/dspgv.f @@ -0,0 +1,278 @@ +*> \brief \b DSPGV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSPGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, ITYPE, LDZ, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is 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 +*> \endverbatim +*> +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangles of A and B are stored; +*> = 'L': Lower triangles of A and B are stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is 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. +*> \endverbatim +*> +*> \param[in,out] BP +*> \verbatim +*> BP is 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. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is 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. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHEReigen +* +* ===================================================================== + SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, + $ INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, ITYPE, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. 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)**T*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**T*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/math/lapack/src/main/fortran/dspgvd.f b/math/lapack/src/main/fortran/dspgvd.f new file mode 100644 index 0000000000..71b290b9c4 --- /dev/null +++ b/math/lapack/src/main/fortran/dspgvd.f @@ -0,0 +1,364 @@ +*> \brief \b DSPGVD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSPGVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, +* LWORK, IWORK, LIWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, ITYPE, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPGVD computes all the eigenvalues, and optionally, the eigenvectors +*> of a real generalized symmetric-definite eigenproblem, of the form +*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and +*> B are assumed to be symmetric, stored in packed format, and B is also +*> positive definite. +*> If eigenvectors are desired, it uses a divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is 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 +*> \endverbatim +*> +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangles of A and B are stored; +*> = 'L': Lower triangles of A and B are stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is 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. +*> \endverbatim +*> +*> \param[in,out] BP +*> \verbatim +*> BP is 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. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is 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. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the required LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If N <= 1, LWORK >= 1. +*> If JOBZ = 'N' and N > 1, LWORK >= 2*N. +*> If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the required sizes of the WORK and IWORK +*> arrays, returns these values as the first entries of the WORK +*> and IWORK arrays, and no error message related to LWORK or +*> LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the required LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If JOBZ = 'N' or N <= 1, LIWORK >= 1. +*> If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the required sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: DPPTRF or DSPEVD returned an error code: +*> <= N: if INFO = i, DSPEVD failed to converge; +*> i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> > N: if INFO = N + i, for 1 <= i <= N, then the leading +*> minor of order i of B is not positive definite. +*> The factorization of B could not be completed and +*> no eigenvalues or eigenvectors were computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHEReigen +* +*> \par Contributors: +* ================== +*> +*> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA +* +* ===================================================================== + SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, + $ LWORK, IWORK, LIWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, ITYPE, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER, WANTZ + CHARACTER TRANS + INTEGER J, LIWMIN, LWMIN, NEIG +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DPPTRF, DSPEVD, DSPGST, DTPMV, DTPSV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + 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.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LIWMIN = 1 + LWMIN = 1 + ELSE + IF( WANTZ ) THEN + LIWMIN = 3 + 5*N + LWMIN = 1 + 6*N + 2*N**2 + ELSE + LIWMIN = 1 + LWMIN = 2*N + END IF + END IF + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPGVD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Form a Cholesky factorization of BP. +* + 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 DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK, + $ LIWORK, INFO ) + LWMIN = MAX( DBLE( LWMIN ), DBLE( WORK( 1 ) ) ) + LIWMIN = MAX( DBLE( LIWMIN ), DBLE( IWORK( 1 ) ) ) +* + 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)**T *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**T *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 +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of DSPGVD +* + END diff --git a/math/lapack/src/main/fortran/dspgvx.f b/math/lapack/src/main/fortran/dspgvx.f new file mode 100644 index 0000000000..8619ef739f --- /dev/null +++ b/math/lapack/src/main/fortran/dspgvx.f @@ -0,0 +1,417 @@ +*> \brief \b DSPGVX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSPGVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, +* IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, +* IFAIL, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, ITYPE, IU, LDZ, M, N +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPGVX computes selected eigenvalues, and optionally, eigenvectors +*> of a real generalized symmetric-definite eigenproblem, of the form +*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A +*> and B are assumed to be symmetric, stored in packed storage, and B +*> is also positive definite. Eigenvalues and eigenvectors can be +*> selected by specifying either a range of values or a range of indices +*> for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is 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 +*> \endverbatim +*> +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A and B are stored; +*> = 'L': Lower triangle of A and B are stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix pencil (A,B). N >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is 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. +*> \endverbatim +*> +*> \param[in,out] BP +*> \verbatim +*> BP is 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. +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing A to tridiagonal form. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*DLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*DLAMCH('S'). +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> On normal exit, the first M elements contain the selected +*> eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'N', then Z is not referenced. +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> The eigenvectors are normalized as follows: +*> if ITYPE = 1 or 2, Z**T*B*Z = I; +*> if ITYPE = 3, Z**T*inv(B)*Z = I. +*> +*> If an eigenvector fails to converge, then that column of Z +*> contains the latest approximation to the eigenvector, and the +*> index of the eigenvector is returned in IFAIL. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (8*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (N) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvectors that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: DPPTRF or DSPEVX returned an error code: +*> <= N: if INFO = i, DSPEVX failed to converge; +*> i eigenvectors failed to converge. Their indices +*> are stored in array IFAIL. +*> > N: if INFO = N + i, for 1 <= i <= N, then the leading +*> minor of order i of B is not positive definite. +*> The factorization of B could not be completed and +*> no eigenvalues or eigenvectors were computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHEReigen +* +*> \par Contributors: +* ================== +*> +*> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA +* +* ===================================================================== + SUBROUTINE DSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, + $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, + $ IFAIL, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, ITYPE, IU, LDZ, M, N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ + CHARACTER TRANS + INTEGER J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DPPTRF, DSPEVX, DSPGST, DTPMV, DTPSV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + UPPER = LSAME( UPLO, 'U' ) + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) +* + 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.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -3 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) THEN + INFO = -9 + END IF + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 ) THEN + INFO = -10 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -11 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -16 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPGVX', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + M = 0 + 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 DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, + $ W, Z, LDZ, WORK, IWORK, IFAIL, INFO ) +* + IF( WANTZ ) THEN +* +* Backtransform eigenvectors to the original problem. +* + IF( INFO.GT.0 ) + $ M = 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)**T*y or inv(U)*y +* + IF( UPPER ) THEN + TRANS = 'N' + ELSE + TRANS = 'T' + END IF +* + DO 10 J = 1, M + 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**T*y +* + IF( UPPER ) THEN + TRANS = 'T' + ELSE + TRANS = 'N' + END IF +* + DO 20 J = 1, M + CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), + $ 1 ) + 20 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSPGVX +* + END diff --git a/math/lapack/src/main/fortran/dsposv.f b/math/lapack/src/main/fortran/dsposv.f new file mode 100644 index 0000000000..0f9eff8b0d --- /dev/null +++ b/math/lapack/src/main/fortran/dsposv.f @@ -0,0 +1,439 @@ +*> \brief DSPOSV computes the solution to system of linear equations A * X = B for PO matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSPOSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, +* SWORK, ITER, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. +* REAL SWORK( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( N, * ), +* $ X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPOSV computes the solution to a real system of linear equations +*> A * X = B, +*> where A is an N-by-N symmetric positive definite matrix and X and B +*> are N-by-NRHS matrices. +*> +*> DSPOSV first attempts to factorize the matrix in SINGLE PRECISION +*> and use this factorization within an iterative refinement procedure +*> to produce a solution with DOUBLE PRECISION normwise backward error +*> quality (see below). If the approach fails the method switches to a +*> DOUBLE PRECISION factorization and solve. +*> +*> The iterative refinement is not going to be a winning strategy if +*> the ratio SINGLE PRECISION performance over DOUBLE PRECISION +*> performance is too small. A reasonable strategy should take the +*> number of right-hand sides and the size of the matrix into account. +*> This might be done with a call to ILAENV in the future. Up to now, we +*> always try iterative refinement. +*> +*> The iterative refinement process is stopped if +*> ITER > ITERMAX +*> or for all the RHS we have: +*> RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX +*> where +*> o ITER is the number of the current iteration in the iterative +*> refinement process +*> o RNRM is the infinity-norm of the residual +*> o XNRM is the infinity-norm of the solution +*> o ANRM is the infinity-operator-norm of the matrix A +*> o EPS is the machine epsilon returned by DLAMCH('Epsilon') +*> The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 +*> respectively. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, +*> dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, if iterative refinement has been successfully used +*> (INFO.EQ.0 and ITER.GE.0, see description below), then A is +*> unchanged, if double precision factorization has been used +*> (INFO.EQ.0 and ITER.LT.0, see description below), then the +*> array A contains the factor U or L from the Cholesky +*> factorization A = U**T*U or A = L*L**T. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The N-by-NRHS right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> If INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N,NRHS) +*> This array is used to hold the residual vectors. +*> \endverbatim +*> +*> \param[out] SWORK +*> \verbatim +*> SWORK is REAL array, dimension (N*(N+NRHS)) +*> This array is used to use the single precision matrix and the +*> right-hand sides or solutions in single precision. +*> \endverbatim +*> +*> \param[out] ITER +*> \verbatim +*> ITER is INTEGER +*> < 0: iterative refinement has failed, double precision +*> factorization has been performed +*> -1 : the routine fell back to full precision for +*> implementation- or machine-specific reasons +*> -2 : narrowing the precision induced an overflow, +*> the routine fell back to full precision +*> -3 : failure of SPOTRF +*> -31: stop the iterative refinement after the 30th +*> iterations +*> > 0: iterative refinement has been successfully used. +*> Returns the number of iterations +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the leading minor of order i of (DOUBLE +*> PRECISION) A is not positive definite, so the +*> factorization could not be completed, and the solution +*> has not been computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doublePOsolve +* +* ===================================================================== + SUBROUTINE DSPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, + $ SWORK, ITER, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. + REAL SWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( N, * ), + $ X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + LOGICAL DOITREF + PARAMETER ( DOITREF = .TRUE. ) +* + INTEGER ITERMAX + PARAMETER ( ITERMAX = 30 ) +* + DOUBLE PRECISION BWDMAX + PARAMETER ( BWDMAX = 1.0E+00 ) +* + DOUBLE PRECISION NEGONE, ONE + PARAMETER ( NEGONE = -1.0D+0, ONE = 1.0D+0 ) +* +* .. Local Scalars .. + INTEGER I, IITER, PTSA, PTSX + DOUBLE PRECISION ANRM, CTE, EPS, RNRM, XNRM +* +* .. External Subroutines .. + EXTERNAL DAXPY, DSYMM, DLACPY, DLAT2S, DLAG2S, SLAG2D, + $ SPOTRF, SPOTRS, XERBLA +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLANSY + LOGICAL LSAME + EXTERNAL IDAMAX, DLAMCH, DLANSY, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 + ITER = 0 +* +* Test the input parameters. +* + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPOSV', -INFO ) + RETURN + END IF +* +* Quick return if (N.EQ.0). +* + IF( N.EQ.0 ) + $ RETURN +* +* Skip single precision iterative refinement if a priori slower +* than double precision factorization. +* + IF( .NOT.DOITREF ) THEN + ITER = -1 + GO TO 40 + END IF +* +* Compute some constants. +* + ANRM = DLANSY( 'I', UPLO, N, A, LDA, WORK ) + EPS = DLAMCH( 'Epsilon' ) + CTE = ANRM*EPS*SQRT( DBLE( N ) )*BWDMAX +* +* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. +* + PTSA = 1 + PTSX = PTSA + N*N +* +* Convert B from double precision to single precision and store the +* result in SX. +* + CALL DLAG2S( N, NRHS, B, LDB, SWORK( PTSX ), N, INFO ) +* + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 + END IF +* +* Convert A from double precision to single precision and store the +* result in SA. +* + CALL DLAT2S( UPLO, N, A, LDA, SWORK( PTSA ), N, INFO ) +* + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 + END IF +* +* Compute the Cholesky factorization of SA. +* + CALL SPOTRF( UPLO, N, SWORK( PTSA ), N, INFO ) +* + IF( INFO.NE.0 ) THEN + ITER = -3 + GO TO 40 + END IF +* +* Solve the system SA*SX = SB. +* + CALL SPOTRS( UPLO, N, NRHS, SWORK( PTSA ), N, SWORK( PTSX ), N, + $ INFO ) +* +* Convert SX back to double precision +* + CALL SLAG2D( N, NRHS, SWORK( PTSX ), N, X, LDX, INFO ) +* +* Compute R = B - AX (R is WORK). +* + CALL DLACPY( 'All', N, NRHS, B, LDB, WORK, N ) +* + CALL DSYMM( 'Left', UPLO, N, NRHS, NEGONE, A, LDA, X, LDX, ONE, + $ WORK, N ) +* +* Check whether the NRHS normwise backward errors satisfy the +* stopping criterion. If yes, set ITER=0 and return. +* + DO I = 1, NRHS + XNRM = ABS( X( IDAMAX( N, X( 1, I ), 1 ), I ) ) + RNRM = ABS( WORK( IDAMAX( N, WORK( 1, I ), 1 ), I ) ) + IF( RNRM.GT.XNRM*CTE ) + $ GO TO 10 + END DO +* +* If we are here, the NRHS normwise backward errors satisfy the +* stopping criterion. We are good to exit. +* + ITER = 0 + RETURN +* + 10 CONTINUE +* + DO 30 IITER = 1, ITERMAX +* +* Convert R (in WORK) from double precision to single precision +* and store the result in SX. +* + CALL DLAG2S( N, NRHS, WORK, N, SWORK( PTSX ), N, INFO ) +* + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 + END IF +* +* Solve the system SA*SX = SR. +* + CALL SPOTRS( UPLO, N, NRHS, SWORK( PTSA ), N, SWORK( PTSX ), N, + $ INFO ) +* +* Convert SX back to double precision and update the current +* iterate. +* + CALL SLAG2D( N, NRHS, SWORK( PTSX ), N, WORK, N, INFO ) +* + DO I = 1, NRHS + CALL DAXPY( N, ONE, WORK( 1, I ), 1, X( 1, I ), 1 ) + END DO +* +* Compute R = B - AX (R is WORK). +* + CALL DLACPY( 'All', N, NRHS, B, LDB, WORK, N ) +* + CALL DSYMM( 'L', UPLO, N, NRHS, NEGONE, A, LDA, X, LDX, ONE, + $ WORK, N ) +* +* Check whether the NRHS normwise backward errors satisfy the +* stopping criterion. If yes, set ITER=IITER>0 and return. +* + DO I = 1, NRHS + XNRM = ABS( X( IDAMAX( N, X( 1, I ), 1 ), I ) ) + RNRM = ABS( WORK( IDAMAX( N, WORK( 1, I ), 1 ), I ) ) + IF( RNRM.GT.XNRM*CTE ) + $ GO TO 20 + END DO +* +* If we are here, the NRHS normwise backward errors satisfy the +* stopping criterion, we are good to exit. +* + ITER = IITER +* + RETURN +* + 20 CONTINUE +* + 30 CONTINUE +* +* If we are at this place of the code, this is because we have +* performed ITER=ITERMAX iterations and never satisified the +* stopping criterion, set up the ITER flag accordingly and follow +* up on double precision routine. +* + ITER = -ITERMAX - 1 +* + 40 CONTINUE +* +* Single-precision iterative refinement failed to converge to a +* satisfactory solution, so we resort to double precision. +* + CALL DPOTRF( UPLO, N, A, LDA, INFO ) +* + IF( INFO.NE.0 ) + $ RETURN +* + CALL DLACPY( 'All', N, NRHS, B, LDB, X, LDX ) + CALL DPOTRS( UPLO, N, NRHS, A, LDA, X, LDX, INFO ) +* + RETURN +* +* End of DSPOSV. +* + END diff --git a/math/lapack/src/main/fortran/dsprfs.f b/math/lapack/src/main/fortran/dsprfs.f new file mode 100644 index 0000000000..9ad5a80b5d --- /dev/null +++ b/math/lapack/src/main/fortran/dsprfs.f @@ -0,0 +1,431 @@ +*> \brief \b DSPRFS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, +* FERR, BERR, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), +* $ FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPRFS improves the computed solution to a system of linear +*> equations when the coefficient matrix is symmetric indefinite +*> and packed, and provides error bounds and backward error estimates +*> for the solution. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> The upper or lower triangle of the symmetric matrix A, packed +*> columnwise in a linear array. The j-th column of A is stored +*> in the array AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. +*> \endverbatim +*> +*> \param[in] AFP +*> \verbatim +*> AFP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> The factored form of the matrix A. AFP contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor U or L from the factorization A = U*D*U**T or +*> A = L*D*L**T as computed by DSPTRF, stored as a packed +*> triangular matrix. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSPTRF. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> On entry, the solution matrix X, as computed by DSPTRS. +*> On exit, the improved solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> ITMAX is the maximum number of steps of iterative refinement. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, + $ FERR, BERR, WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), + $ FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. 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 UPPER + INTEGER COUNT, I, IK, J, K, KASE, KK, NZ + DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLACN2, DSPMV, DSPTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. 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( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPRFS', -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 +* +* 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 - A * X +* + CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) + CALL DSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ), + $ 1 ) +* +* Compute componentwise relative backward error from formula +* +* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) +* +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. If the i-th component of the denominator is less +* than SAFE2, then SAFE1 is added to the i-th components of the +* numerator and denominator before dividing. +* + DO 30 I = 1, N + WORK( I ) = ABS( B( I, J ) ) + 30 CONTINUE +* +* Compute abs(A)*abs(X) + abs(B). +* + KK = 1 + IF( UPPER ) THEN + DO 50 K = 1, N + S = ZERO + XK = ABS( X( K, J ) ) + IK = KK + DO 40 I = 1, K - 1 + WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK + S = S + ABS( AP( IK ) )*ABS( X( I, J ) ) + IK = IK + 1 + 40 CONTINUE + WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S + KK = KK + K + 50 CONTINUE + ELSE + DO 70 K = 1, N + S = ZERO + XK = ABS( X( K, J ) ) + WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK + IK = KK + 1 + DO 60 I = K + 1, N + WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK + S = S + ABS( AP( IK ) )*ABS( X( I, J ) ) + IK = IK + 1 + 60 CONTINUE + WORK( K ) = WORK( K ) + S + KK = KK + ( N-K+1 ) + 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 DSPTRS( UPLO, N, 1, AFP, 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(A))* +* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) +* +* where +* norm(Z) is the magnitude of the largest component of Z +* inv(A) is the inverse of A +* abs(Z) is the componentwise absolute value of the matrix or +* vector Z +* NZ is the maximum number of nonzeros in any row of A, plus 1 +* EPS is machine epsilon +* +* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) +* is incremented by SAFE1 if the i-th component of +* abs(A)*abs(X) + abs(B) is less than SAFE2. +* +* Use DLACN2 to estimate the infinity-norm of the matrix +* inv(A) * diag(W), +* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) +* + 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(A**T). +* + CALL DSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N, + $ INFO ) + DO 110 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 110 CONTINUE + ELSE IF( KASE.EQ.2 ) THEN +* +* Multiply by inv(A)*diag(W). +* + DO 120 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 120 CONTINUE + CALL DSPTRS( UPLO, N, 1, AFP, 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 DSPRFS +* + END diff --git a/math/lapack/src/main/fortran/dspsv.f b/math/lapack/src/main/fortran/dspsv.f new file mode 100644 index 0000000000..e96943925c --- /dev/null +++ b/math/lapack/src/main/fortran/dspsv.f @@ -0,0 +1,224 @@ +*> \brief DSPSV computes the solution to system of linear equations A * X = B for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSPSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION AP( * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPSV computes the solution to a real system of linear equations +*> A * X = B, +*> where A is an N-by-N symmetric matrix stored in packed format and X +*> and B are N-by-NRHS matrices. +*> +*> The diagonal pivoting method is used to factor A as +*> A = U * D * U**T, if UPLO = 'U', or +*> A = L * D * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, D is symmetric and block diagonal with 1-by-1 +*> and 2-by-2 diagonal blocks. The factored form of A is then used to +*> solve the system of equations A * X = B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> On entry, the upper or lower triangle of the symmetric matrix +*> A, packed columnwise in a linear array. The j-th column of A +*> is stored in the array AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +*> See below for further details. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L from the factorization +*> A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as +*> a packed triangular matrix in the same storage format as A. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, as +*> determined by DSPTRF. If IPIV(k) > 0, then rows and columns +*> k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 +*> diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, +*> then rows and columns k-1 and -IPIV(k) were interchanged and +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and +*> IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and +*> -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 +*> diagonal block. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, so the solution could not be +*> computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERsolve +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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 ] +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION AP( * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSPTRF, DSPTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + 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( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPSV ', -INFO ) + RETURN + END IF +* +* Compute the factorization A = U*D*U**T or A = L*D*L**T. +* + CALL DSPTRF( UPLO, N, AP, IPIV, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) +* + END IF + RETURN +* +* End of DSPSV +* + END diff --git a/math/lapack/src/main/fortran/dspsvx.f b/math/lapack/src/main/fortran/dspsvx.f new file mode 100644 index 0000000000..b95c610ba8 --- /dev/null +++ b/math/lapack/src/main/fortran/dspsvx.f @@ -0,0 +1,386 @@ +*> \brief DSPSVX computes the solution to system of linear equations A * X = B for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSPSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, +* LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER FACT, UPLO +* INTEGER INFO, LDB, LDX, N, NRHS +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), +* $ FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPSVX uses the diagonal pivoting factorization A = U*D*U**T or +*> A = L*D*L**T to compute the solution to a real system of linear +*> equations A * X = B, where A is an N-by-N symmetric matrix stored +*> in packed format and X and B are N-by-NRHS matrices. +*> +*> Error bounds on the solution and a condition estimate are also +*> provided. +*> \endverbatim +* +*> \par Description: +* ================= +*> +*> \verbatim +*> +*> The following steps are performed: +*> +*> 1. If FACT = 'N', the diagonal pivoting method is used to factor A as +*> A = U * D * U**T, if UPLO = 'U', or +*> A = L * D * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices and D is symmetric and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. +*> +*> 2. If some D(i,i)=0, so that D is exactly singular, then the routine +*> returns with INFO = i. Otherwise, the factored form of A is used +*> to estimate the condition number of the matrix A. If the +*> reciprocal of the condition number is less than machine precision, +*> INFO = N+1 is returned as a warning, but the routine still goes on +*> to solve for X and compute error bounds as described below. +*> +*> 3. The system of equations is solved for X using the factored form +*> of A. +*> +*> 4. Iterative refinement is applied to improve the computed solution +*> matrix and calculate error bounds and backward error estimates +*> for it. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> Specifies whether or not the factored form of A has been +*> supplied on entry. +*> = 'F': On entry, AFP and IPIV contain the factored form of +*> A. AP, AFP and IPIV will not be modified. +*> = 'N': The matrix A will be copied to AFP and factored. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> The upper or lower triangle of the symmetric matrix A, packed +*> columnwise in a linear array. The j-th column of A is stored +*> in the array AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. +*> See below for further details. +*> \endverbatim +*> +*> \param[in,out] AFP +*> \verbatim +*> AFP is DOUBLE PRECISION array, dimension +*> (N*(N+1)/2) +*> If FACT = 'F', then AFP is an input argument and on entry +*> contains the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L from the factorization +*> A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as +*> a packed triangular matrix in the same storage format as A. +*> +*> If FACT = 'N', then AFP is an output argument and on exit +*> contains the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L from the factorization +*> A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as +*> a packed triangular matrix in the same storage format as A. +*> \endverbatim +*> +*> \param[in,out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> If FACT = 'F', then IPIV is an input argument and on entry +*> contains details of the interchanges and the block structure +*> of D, as determined by DSPTRF. +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and +*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) +*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = +*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were +*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> +*> If FACT = 'N', then IPIV is an output argument and on exit +*> contains details of the interchanges and the block structure +*> of D, as determined by DSPTRF. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The N-by-NRHS right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The estimate of the reciprocal condition number of the matrix +*> A. If RCOND is less than the machine precision (in +*> particular, if RCOND = 0), the matrix is singular to working +*> precision. This condition is indicated by a return code of +*> INFO > 0. +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, and i is +*> <= N: D(i,i) is exactly zero. The factorization +*> has been completed but the factor D is exactly +*> singular, so the solution and error bounds could +*> not be computed. RCOND = 0 is returned. +*> = N+1: D is nonsingular, but RCOND is less than machine +*> precision, meaning that the matrix is singular +*> to working precision. Nevertheless, the +*> solution and error bounds are computed because +*> there are a number of situations where the +*> computed solution can be more accurate than the +*> value of RCOND would suggest. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleOTHERsolve +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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 ] +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, + $ LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER FACT, UPLO + INTEGER INFO, LDB, LDX, N, NRHS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), + $ FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOFACT + DOUBLE PRECISION ANORM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSP + EXTERNAL LSAME, DLAMCH, DLANSP +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DSPCON, DSPRFS, DSPTRF, DSPTRS, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) + $ THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPSVX', -INFO ) + RETURN + END IF +* + IF( NOFACT ) THEN +* +* Compute the factorization A = U*D*U**T or A = L*D*L**T. +* + CALL DCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 ) + CALL DSPTRF( UPLO, N, AFP, IPIV, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 )THEN + RCOND = ZERO + RETURN + END IF + END IF +* +* Compute the norm of the matrix A. +* + ANORM = DLANSP( 'I', UPLO, N, AP, WORK ) +* +* Compute the reciprocal of the condition number of A. +* + CALL DSPCON( UPLO, N, AFP, IPIV, ANORM, RCOND, WORK, IWORK, INFO ) +* +* Compute the solution vectors X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DSPTRS( UPLO, N, NRHS, AFP, IPIV, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solutions and +* compute error bounds and backward error estimates for them. +* + CALL DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, + $ BERR, WORK, IWORK, INFO ) +* +* Set INFO = N+1 if the matrix is singular to working precision. +* + IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) + $ INFO = N + 1 +* + RETURN +* +* End of DSPSVX +* + END diff --git a/math/lapack/src/main/fortran/dsptrd.f b/math/lapack/src/main/fortran/dsptrd.f new file mode 100644 index 0000000000..082f814098 --- /dev/null +++ b/math/lapack/src/main/fortran/dsptrd.f @@ -0,0 +1,300 @@ +*> \brief \b DSPTRD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSPTRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is 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. +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of the tridiagonal matrix T: +*> D(i) = A(i,i). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is 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'. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-1) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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**T +*> +*> 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**T +*> +*> 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). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * ) +* .. +* +* ===================================================================== +* +* .. 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**T +* 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**T *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**T - w * v**T +* + 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**T +* 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**T *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**T - w * v**T +* + 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/math/lapack/src/main/fortran/dsptrf.f b/math/lapack/src/main/fortran/dsptrf.f new file mode 100644 index 0000000000..9158ff1f38 --- /dev/null +++ b/math/lapack/src/main/fortran/dsptrf.f @@ -0,0 +1,616 @@ +*> \brief \b DSPTRF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSPTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION AP( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is 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). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, 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**T, 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). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> J. Lewis, Boeing Computer Services Company +*> +* ===================================================================== + SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION AP( * ) +* .. +* +* ===================================================================== +* +* .. 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**T 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 +* + 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)**T = A - W(k)*1/D(k)*W(k)**T +* + 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) )**T +* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**T +* + 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**T 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)**T = A - W(k)*(1/D(k))*W(k)**T +* + 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) )**T +* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )**T +* +* where L(k) and L(k+1) are the k-th and (k+1)-th +* columns of L +* + 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/math/lapack/src/main/fortran/dsptri.f b/math/lapack/src/main/fortran/dsptri.f new file mode 100644 index 0000000000..e68efface8 --- /dev/null +++ b/math/lapack/src/main/fortran/dsptri.f @@ -0,0 +1,401 @@ +*> \brief \b DSPTRI +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION AP( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPTRI computes the inverse of a real symmetric indefinite matrix +*> A in packed storage using the factorization A = U*D*U**T or +*> A = L*D*L**T computed by DSPTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> On entry, the block diagonal matrix D and the multipliers +*> used to obtain the factor U or L as computed by DSPTRF, +*> stored as a packed triangular matrix. +*> +*> On exit, if INFO = 0, the (symmetric) inverse of the original +*> matrix, stored as a packed triangular matrix. The j-th column +*> of inv(A) is stored in the array AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; +*> if UPLO = 'L', +*> AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSPTRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION AP( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP + DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSPMV, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. 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( 'DSPTRI', -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 +* + KP = N*( N+1 ) / 2 + DO 10 INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO ) + $ RETURN + KP = KP - INFO + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + KP = 1 + DO 20 INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO ) + $ RETURN + KP = KP + N - INFO + 1 + 20 CONTINUE + END IF + INFO = 0 +* + IF( UPPER ) THEN +* +* Compute inv(A) from the factorization A = U*D*U**T. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + KC = 1 + 30 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 50 +* + KCNEXT = KC + K + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + AP( KC+K-1 ) = ONE / AP( KC+K-1 ) +* +* Compute column K of the inverse. +* + IF( K.GT.1 ) THEN + CALL DCOPY( K-1, AP( KC ), 1, WORK, 1 ) + CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ), + $ 1 ) + AP( KC+K-1 ) = AP( KC+K-1 ) - + $ DDOT( K-1, WORK, 1, AP( KC ), 1 ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = ABS( AP( KCNEXT+K-1 ) ) + AK = AP( KC+K-1 ) / T + AKP1 = AP( KCNEXT+K ) / T + AKKP1 = AP( KCNEXT+K-1 ) / T + D = T*( AK*AKP1-ONE ) + AP( KC+K-1 ) = AKP1 / D + AP( KCNEXT+K ) = AK / D + AP( KCNEXT+K-1 ) = -AKKP1 / D +* +* Compute columns K and K+1 of the inverse. +* + IF( K.GT.1 ) THEN + CALL DCOPY( K-1, AP( KC ), 1, WORK, 1 ) + CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ), + $ 1 ) + AP( KC+K-1 ) = AP( KC+K-1 ) - + $ DDOT( K-1, WORK, 1, AP( KC ), 1 ) + AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) - + $ DDOT( K-1, AP( KC ), 1, AP( KCNEXT ), + $ 1 ) + CALL DCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 ) + CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, + $ AP( KCNEXT ), 1 ) + AP( KCNEXT+K ) = AP( KCNEXT+K ) - + $ DDOT( K-1, WORK, 1, AP( KCNEXT ), 1 ) + END IF + KSTEP = 2 + KCNEXT = KCNEXT + K + 1 + 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) +* + KPC = ( KP-1 )*KP / 2 + 1 + CALL DSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 ) + KX = KPC + KP - 1 + DO 40 J = KP + 1, K - 1 + KX = KX + J - 1 + TEMP = AP( KC+J-1 ) + AP( KC+J-1 ) = AP( KX ) + AP( KX ) = TEMP + 40 CONTINUE + TEMP = AP( KC+K-1 ) + AP( KC+K-1 ) = AP( KPC+KP-1 ) + AP( KPC+KP-1 ) = TEMP + IF( KSTEP.EQ.2 ) THEN + TEMP = AP( KC+K+K-1 ) + AP( KC+K+K-1 ) = AP( KC+K+KP-1 ) + AP( KC+K+KP-1 ) = TEMP + END IF + END IF +* + K = K + KSTEP + KC = KCNEXT + GO TO 30 + 50 CONTINUE +* + ELSE +* +* Compute inv(A) from the factorization A = L*D*L**T. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + NPP = N*( N+1 ) / 2 + K = N + KC = NPP + 60 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 80 +* + KCNEXT = KC - ( N-K+2 ) + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + AP( KC ) = ONE / AP( KC ) +* +* Compute column K of the inverse. +* + IF( K.LT.N ) THEN + CALL DCOPY( N-K, AP( KC+1 ), 1, WORK, 1 ) + CALL DSPMV( UPLO, N-K, -ONE, AP( KC+N-K+1 ), WORK, 1, + $ ZERO, AP( KC+1 ), 1 ) + AP( KC ) = AP( KC ) - DDOT( N-K, WORK, 1, AP( KC+1 ), 1 ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = ABS( AP( KCNEXT+1 ) ) + AK = AP( KCNEXT ) / T + AKP1 = AP( KC ) / T + AKKP1 = AP( KCNEXT+1 ) / T + D = T*( AK*AKP1-ONE ) + AP( KCNEXT ) = AKP1 / D + AP( KC ) = AK / D + AP( KCNEXT+1 ) = -AKKP1 / D +* +* Compute columns K-1 and K of the inverse. +* + IF( K.LT.N ) THEN + CALL DCOPY( N-K, AP( KC+1 ), 1, WORK, 1 ) + CALL DSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1, + $ ZERO, AP( KC+1 ), 1 ) + AP( KC ) = AP( KC ) - DDOT( N-K, WORK, 1, AP( KC+1 ), 1 ) + AP( KCNEXT+1 ) = AP( KCNEXT+1 ) - + $ DDOT( N-K, AP( KC+1 ), 1, + $ AP( KCNEXT+2 ), 1 ) + CALL DCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 ) + CALL DSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1, + $ ZERO, AP( KCNEXT+2 ), 1 ) + AP( KCNEXT ) = AP( KCNEXT ) - + $ DDOT( N-K, WORK, 1, AP( KCNEXT+2 ), 1 ) + END IF + KSTEP = 2 + KCNEXT = KCNEXT - ( N-K+3 ) + 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) +* + KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1 + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 ) + KX = KC + KP - K + DO 70 J = K + 1, KP - 1 + KX = KX + N - J + 1 + TEMP = AP( KC+J-K ) + AP( KC+J-K ) = AP( KX ) + AP( KX ) = TEMP + 70 CONTINUE + TEMP = AP( KC ) + AP( KC ) = AP( KPC ) + AP( KPC ) = TEMP + IF( KSTEP.EQ.2 ) THEN + TEMP = AP( KC-N+K-1 ) + AP( KC-N+K-1 ) = AP( KC-N+KP-1 ) + AP( KC-N+KP-1 ) = TEMP + END IF + END IF +* + K = K - KSTEP + KC = KCNEXT + GO TO 60 + 80 CONTINUE + END IF +* + RETURN +* +* End of DSPTRI +* + END diff --git a/math/lapack/src/main/fortran/dsptrs.f b/math/lapack/src/main/fortran/dsptrs.f new file mode 100644 index 0000000000..17f8c6a5f4 --- /dev/null +++ b/math/lapack/src/main/fortran/dsptrs.f @@ -0,0 +1,450 @@ +*> \brief \b DSPTRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION AP( * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPTRS solves a system of linear equations A*X = B with a real +*> symmetric matrix A stored in packed format using the factorization +*> A = U*D*U**T or A = L*D*L**T computed by DSPTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by DSPTRF, stored as a +*> packed triangular matrix. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSPTRF. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION AP( * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, K, KC, 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( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPTRS', -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**T. +* +* First solve U*D*X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + KC = N*( N+1 ) / 2 + 1 + 10 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 30 +* + KC = KC - K + 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, AP( KC ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL DSCAL( NRHS, ONE / AP( KC+K-1 ), 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, AP( KC ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) + CALL DGER( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1, + $ B( K-1, 1 ), LDB, B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + AKM1K = AP( KC+K-2 ) + AKM1 = AP( KC-1 ) / AKM1K + AK = AP( KC+K-1 ) / AKM1K + DENOM = AKM1*AK - 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 + KC = KC - K + 1 + K = K - 2 + END IF +* + GO TO 10 + 30 CONTINUE +* +* Next solve U**T*X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + KC = 1 + 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**T(K)), where U(K) is the transformation +* stored in column K of A. +* + CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ), + $ 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 ) + KC = KC + K + K = K + 1 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(U**T(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, AP( KC ), + $ 1, ONE, B( K, 1 ), LDB ) + CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, + $ AP( KC+K ), 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 ) + KC = KC + 2*K + 1 + K = K + 2 + END IF +* + GO TO 40 + 50 CONTINUE +* + ELSE +* +* Solve A*X = B, where A = L*D*L**T. +* +* First solve L*D*X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + KC = 1 + 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, AP( KC+1 ), 1, B( K, 1 ), + $ LDB, B( K+1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL DSCAL( NRHS, ONE / AP( KC ), B( K, 1 ), LDB ) + KC = KC + N - K + 1 + 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, AP( KC+2 ), 1, B( K, 1 ), + $ LDB, B( K+2, 1 ), LDB ) + CALL DGER( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1, + $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. +* + AKM1K = AP( KC+1 ) + AKM1 = AP( KC ) / AKM1K + AK = AP( KC+N-K+1 ) / AKM1K + DENOM = AKM1*AK - 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 + KC = KC + 2*( N-K ) + 1 + K = K + 2 + END IF +* + GO TO 60 + 80 CONTINUE +* +* Next solve L**T*X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + KC = N*( N+1 ) / 2 + 1 + 90 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 100 +* + KC = KC - ( N-K+1 ) + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Multiply by inv(L**T(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, AP( KC+1 ), 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**T(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, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB ) + CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, AP( KC-( N-K ) ), 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 ) + KC = KC - ( N-K+2 ) + K = K - 2 + END IF +* + GO TO 90 + 100 CONTINUE + END IF +* + RETURN +* +* End of DSPTRS +* + END diff --git a/math/lapack/src/main/fortran/dstebz.f b/math/lapack/src/main/fortran/dstebz.f new file mode 100644 index 0000000000..e41279e542 --- /dev/null +++ b/math/lapack/src/main/fortran/dstebz.f @@ -0,0 +1,771 @@ +*> \brief \b DSTEBZ +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSTEBZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, +* M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER ORDER, RANGE +* INTEGER IL, INFO, IU, M, N, NSPLIT +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ) +* DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSTEBZ computes the eigenvalues of a symmetric tridiagonal +*> matrix T. The user may ask for all eigenvalues, all eigenvalues +*> in the half-open interval (VL, VU], or the IL-th through IU-th +*> eigenvalues. +*> +*> To avoid overflow, the matrix must be scaled so that its +*> largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest +*> accuracy, it should not be much smaller than that. +*> +*> See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal +*> Matrix", Report CS41, Computer Science Dept., Stanford +*> University, July 21, 1966. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': ("All") all eigenvalues will be found. +*> = 'V': ("Value") all eigenvalues in the half-open interval +*> (VL, VU] will be found. +*> = 'I': ("Index") the IL-th through IU-th eigenvalues (of the +*> entire matrix) will be found. +*> \endverbatim +*> +*> \param[in] ORDER +*> \verbatim +*> ORDER is CHARACTER*1 +*> = 'B': ("By Block") the eigenvalues will be grouped by +*> split-off block (see IBLOCK, ISPLIT) and +*> ordered from smallest to largest within +*> the block. +*> = 'E': ("Entire matrix") +*> the eigenvalues for the entire matrix +*> will be ordered from smallest to +*> largest. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the tridiagonal matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. Eigenvalues less than or equal +*> to VL, or greater than VU, will not be returned. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. Eigenvalues less than or equal +*> to VL, or greater than VU, will not be returned. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute tolerance for the eigenvalues. An eigenvalue +*> (or cluster) is considered to be located if it has been +*> determined to lie in an interval whose width is ABSTOL or +*> less. If ABSTOL is less than or equal to zero, then ULP*|T| +*> will be used, where |T| means the 1-norm of T. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*DLAMCH('S'), not zero. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) off-diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The actual number of eigenvalues found. 0 <= M <= N. +*> (See also the description of INFO=2,3.) +*> \endverbatim +*> +*> \param[out] NSPLIT +*> \verbatim +*> NSPLIT is INTEGER +*> The number of diagonal blocks in the matrix T. +*> 1 <= NSPLIT <= N. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> On exit, the first M elements of W will contain the +*> eigenvalues. (DSTEBZ may use the remaining N-M elements as +*> workspace.) +*> \endverbatim +*> +*> \param[out] IBLOCK +*> \verbatim +*> IBLOCK is INTEGER array, dimension (N) +*> At each row/column j where E(j) is zero or small, the +*> matrix T is considered to split into a block diagonal +*> matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which +*> block (from 1 to the number of blocks) the eigenvalue W(i) +*> belongs. (DSTEBZ may use the remaining N-M elements as +*> workspace.) +*> \endverbatim +*> +*> \param[out] ISPLIT +*> \verbatim +*> ISPLIT is INTEGER array, dimension (N) +*> The splitting points, at which T breaks up into submatrices. +*> The first submatrix consists of rows/columns 1 to ISPLIT(1), +*> the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), +*> etc., and the NSPLIT-th consists of rows/columns +*> ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. +*> (Only the first NSPLIT elements will actually be used, but +*> since the user cannot know a priori what value NSPLIT will +*> have, N words must be reserved for ISPLIT.) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: some or all of the eigenvalues failed to converge or +*> were not computed: +*> =1 or 3: Bisection failed to converge for some +*> eigenvalues; these eigenvalues are flagged by a +*> negative block number. The effect is that the +*> eigenvalues may not be as accurate as the +*> absolute and relative tolerances. This is +*> generally caused by unexpectedly inaccurate +*> arithmetic. +*> =2 or 3: RANGE='I' only: Not all of the eigenvalues +*> IL:IU were found. +*> Effect: M < IU+1-IL +*> Cause: non-monotonic arithmetic, causing the +*> Sturm sequence to be non-monotonic. +*> Cure: recalculate, using RANGE='A', and pick +*> out eigenvalues IL:IU. In some cases, +*> increasing the PARAMETER "FUDGE" may +*> make things work. +*> = 4: RANGE='I', and the Gershgorin interval +*> initially used was too small. No eigenvalues +*> were computed. +*> Probable cause: your machine has sloppy +*> floating-point arithmetic. +*> Cure: Increase the PARAMETER "FUDGE", +*> recompile, and try again. +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> RELFAC DOUBLE PRECISION, default = 2.0e0 +*> The relative tolerance. An interval (a,b] lies within +*> "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|), +*> where "ulp" is the machine precision (distance from 1 to +*> the next larger floating point number.) +*> +*> FUDGE DOUBLE PRECISION, default = 2 +*> A "fudge factor" to widen the Gershgorin intervals. Ideally, +*> a value of 1 should work, but on machines with sloppy +*> arithmetic, this needs to be larger. The default for +*> publicly released versions should be large enough to handle +*> the worst machine around. Note that this has no effect +*> on accuracy of the solution. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, + $ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER ORDER, RANGE + INTEGER IL, INFO, IU, M, N, NSPLIT + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, HALF + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ HALF = 1.0D0 / TWO ) + DOUBLE PRECISION FUDGE, RELFAC + PARAMETER ( FUDGE = 2.1D0, RELFAC = 2.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL NCNVRG, TOOFEW + INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO, + $ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX, + $ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL, + $ NWU + DOUBLE PRECISION ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN, + $ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, ILAENV, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLAEBZ, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Decode RANGE +* + IF( LSAME( RANGE, 'A' ) ) THEN + IRANGE = 1 + ELSE IF( LSAME( RANGE, 'V' ) ) THEN + IRANGE = 2 + ELSE IF( LSAME( RANGE, 'I' ) ) THEN + IRANGE = 3 + ELSE + IRANGE = 0 + END IF +* +* Decode ORDER +* + IF( LSAME( ORDER, 'B' ) ) THEN + IORDER = 2 + ELSE IF( LSAME( ORDER, 'E' ) ) THEN + IORDER = 1 + ELSE + IORDER = 0 + END IF +* +* Check for Errors +* + IF( IRANGE.LE.0 ) THEN + INFO = -1 + ELSE IF( IORDER.LE.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( IRANGE.EQ.2 ) THEN + IF( VL.GE.VU ) + $ INFO = -5 + ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) + $ THEN + INFO = -6 + ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) + $ THEN + INFO = -7 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSTEBZ', -INFO ) + RETURN + END IF +* +* Initialize error flags +* + INFO = 0 + NCNVRG = .FALSE. + TOOFEW = .FALSE. +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) + $ RETURN +* +* Simplifications: +* + IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N ) + $ IRANGE = 1 +* +* Get machine constants +* NB is the minimum vector length for vector bisection, or 0 +* if only scalar is to be done. +* + SAFEMN = DLAMCH( 'S' ) + ULP = DLAMCH( 'P' ) + RTOLI = ULP*RELFAC + NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 ) + IF( NB.LE.1 ) + $ NB = 0 +* +* Special Case when N=1 +* + IF( N.EQ.1 ) THEN + NSPLIT = 1 + ISPLIT( 1 ) = 1 + IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN + M = 0 + ELSE + W( 1 ) = D( 1 ) + IBLOCK( 1 ) = 1 + M = 1 + END IF + RETURN + END IF +* +* Compute Splitting Points +* + NSPLIT = 1 + WORK( N ) = ZERO + PIVMIN = ONE +* + DO 10 J = 2, N + TMP1 = E( J-1 )**2 + IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN + ISPLIT( NSPLIT ) = J - 1 + NSPLIT = NSPLIT + 1 + WORK( J-1 ) = ZERO + ELSE + WORK( J-1 ) = TMP1 + PIVMIN = MAX( PIVMIN, TMP1 ) + END IF + 10 CONTINUE + ISPLIT( NSPLIT ) = N + PIVMIN = PIVMIN*SAFEMN +* +* Compute Interval and ATOLI +* + IF( IRANGE.EQ.3 ) THEN +* +* RANGE='I': Compute the interval containing eigenvalues +* IL through IU. +* +* Compute Gershgorin interval for entire (split) matrix +* and use it as the initial interval +* + GU = D( 1 ) + GL = D( 1 ) + TMP1 = ZERO +* + DO 20 J = 1, N - 1 + TMP2 = SQRT( WORK( J ) ) + GU = MAX( GU, D( J )+TMP1+TMP2 ) + GL = MIN( GL, D( J )-TMP1-TMP2 ) + TMP1 = TMP2 + 20 CONTINUE +* + GU = MAX( GU, D( N )+TMP1 ) + GL = MIN( GL, D( N )-TMP1 ) + TNORM = MAX( ABS( GL ), ABS( GU ) ) + GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN + GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN +* +* Compute Iteration parameters +* + ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) / + $ LOG( TWO ) ) + 2 + IF( ABSTOL.LE.ZERO ) THEN + ATOLI = ULP*TNORM + ELSE + ATOLI = ABSTOL + END IF +* + WORK( N+1 ) = GL + WORK( N+2 ) = GL + WORK( N+3 ) = GU + WORK( N+4 ) = GU + WORK( N+5 ) = GL + WORK( N+6 ) = GU + IWORK( 1 ) = -1 + IWORK( 2 ) = -1 + IWORK( 3 ) = N + 1 + IWORK( 4 ) = N + 1 + IWORK( 5 ) = IL - 1 + IWORK( 6 ) = IU +* + CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E, + $ WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT, + $ IWORK, W, IBLOCK, IINFO ) +* + IF( IWORK( 6 ).EQ.IU ) THEN + WL = WORK( N+1 ) + WLU = WORK( N+3 ) + NWL = IWORK( 1 ) + WU = WORK( N+4 ) + WUL = WORK( N+2 ) + NWU = IWORK( 4 ) + ELSE + WL = WORK( N+2 ) + WLU = WORK( N+4 ) + NWL = IWORK( 2 ) + WU = WORK( N+3 ) + WUL = WORK( N+1 ) + NWU = IWORK( 3 ) + END IF +* + IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN + INFO = 4 + RETURN + END IF + ELSE +* +* RANGE='A' or 'V' -- Set ATOLI +* + TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), + $ ABS( D( N ) )+ABS( E( N-1 ) ) ) +* + DO 30 J = 2, N - 1 + TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+ + $ ABS( E( J ) ) ) + 30 CONTINUE +* + IF( ABSTOL.LE.ZERO ) THEN + ATOLI = ULP*TNORM + ELSE + ATOLI = ABSTOL + END IF +* + IF( IRANGE.EQ.2 ) THEN + WL = VL + WU = VU + ELSE + WL = ZERO + WU = ZERO + END IF + END IF +* +* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU. +* NWL accumulates the number of eigenvalues .le. WL, +* NWU accumulates the number of eigenvalues .le. WU +* + M = 0 + IEND = 0 + INFO = 0 + NWL = 0 + NWU = 0 +* + DO 70 JB = 1, NSPLIT + IOFF = IEND + IBEGIN = IOFF + 1 + IEND = ISPLIT( JB ) + IN = IEND - IOFF +* + IF( IN.EQ.1 ) THEN +* +* Special Case -- IN=1 +* + IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN ) + $ NWL = NWL + 1 + IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN ) + $ NWU = NWU + 1 + IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE. + $ D( IBEGIN )-PIVMIN ) ) THEN + M = M + 1 + W( M ) = D( IBEGIN ) + IBLOCK( M ) = JB + END IF + ELSE +* +* General Case -- IN > 1 +* +* Compute Gershgorin Interval +* and use it as the initial interval +* + GU = D( IBEGIN ) + GL = D( IBEGIN ) + TMP1 = ZERO +* + DO 40 J = IBEGIN, IEND - 1 + TMP2 = ABS( E( J ) ) + GU = MAX( GU, D( J )+TMP1+TMP2 ) + GL = MIN( GL, D( J )-TMP1-TMP2 ) + TMP1 = TMP2 + 40 CONTINUE +* + GU = MAX( GU, D( IEND )+TMP1 ) + GL = MIN( GL, D( IEND )-TMP1 ) + BNORM = MAX( ABS( GL ), ABS( GU ) ) + GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN + GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN +* +* Compute ATOLI for the current submatrix +* + IF( ABSTOL.LE.ZERO ) THEN + ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) ) + ELSE + ATOLI = ABSTOL + END IF +* + IF( IRANGE.GT.1 ) THEN + IF( GU.LT.WL ) THEN + NWL = NWL + IN + NWU = NWU + IN + GO TO 70 + END IF + GL = MAX( GL, WL ) + GU = MIN( GU, WU ) + IF( GL.GE.GU ) + $ GO TO 70 + END IF +* +* Set Up Initial Interval +* + WORK( N+1 ) = GL + WORK( N+IN+1 ) = GU + CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, + $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), + $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM, + $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) +* + NWL = NWL + IWORK( 1 ) + NWU = NWU + IWORK( IN+1 ) + IWOFF = M - IWORK( 1 ) +* +* Compute Eigenvalues +* + ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) / + $ LOG( TWO ) ) + 2 + CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, + $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), + $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT, + $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) +* +* Copy Eigenvalues Into W and IBLOCK +* Use -JB for block number for unconverged eigenvalues. +* + DO 60 J = 1, IOUT + TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) ) +* +* Flag non-convergence. +* + IF( J.GT.IOUT-IINFO ) THEN + NCNVRG = .TRUE. + IB = -JB + ELSE + IB = JB + END IF + DO 50 JE = IWORK( J ) + 1 + IWOFF, + $ IWORK( J+IN ) + IWOFF + W( JE ) = TMP1 + IBLOCK( JE ) = IB + 50 CONTINUE + 60 CONTINUE +* + M = M + IM + END IF + 70 CONTINUE +* +* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU +* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. +* + IF( IRANGE.EQ.3 ) THEN + IM = 0 + IDISCL = IL - 1 - NWL + IDISCU = NWU - IU +* + IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN + DO 80 JE = 1, M + IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN + IDISCL = IDISCL - 1 + ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN + IDISCU = IDISCU - 1 + ELSE + IM = IM + 1 + W( IM ) = W( JE ) + IBLOCK( IM ) = IBLOCK( JE ) + END IF + 80 CONTINUE + M = IM + END IF + IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN +* +* Code to deal with effects of bad arithmetic: +* Some low eigenvalues to be discarded are not in (WL,WLU], +* or high eigenvalues to be discarded are not in (WUL,WU] +* so just kill off the smallest IDISCL/largest IDISCU +* eigenvalues, by simply finding the smallest/largest +* eigenvalue(s). +* +* (If N(w) is monotone non-decreasing, this should never +* happen.) +* + IF( IDISCL.GT.0 ) THEN + WKILL = WU + DO 100 JDISC = 1, IDISCL + IW = 0 + DO 90 JE = 1, M + IF( IBLOCK( JE ).NE.0 .AND. + $ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN + IW = JE + WKILL = W( JE ) + END IF + 90 CONTINUE + IBLOCK( IW ) = 0 + 100 CONTINUE + END IF + IF( IDISCU.GT.0 ) THEN +* + WKILL = WL + DO 120 JDISC = 1, IDISCU + IW = 0 + DO 110 JE = 1, M + IF( IBLOCK( JE ).NE.0 .AND. + $ ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN + IW = JE + WKILL = W( JE ) + END IF + 110 CONTINUE + IBLOCK( IW ) = 0 + 120 CONTINUE + END IF + IM = 0 + DO 130 JE = 1, M + IF( IBLOCK( JE ).NE.0 ) THEN + IM = IM + 1 + W( IM ) = W( JE ) + IBLOCK( IM ) = IBLOCK( JE ) + END IF + 130 CONTINUE + M = IM + END IF + IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN + TOOFEW = .TRUE. + END IF + END IF +* +* If ORDER='B', do nothing -- the eigenvalues are already sorted +* by block. +* If ORDER='E', sort the eigenvalues from smallest to largest +* + IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN + DO 150 JE = 1, M - 1 + IE = 0 + TMP1 = W( JE ) + DO 140 J = JE + 1, M + IF( W( J ).LT.TMP1 ) THEN + IE = J + TMP1 = W( J ) + END IF + 140 CONTINUE +* + IF( IE.NE.0 ) THEN + ITMP1 = IBLOCK( IE ) + W( IE ) = W( JE ) + IBLOCK( IE ) = IBLOCK( JE ) + W( JE ) = TMP1 + IBLOCK( JE ) = ITMP1 + END IF + 150 CONTINUE + END IF +* + INFO = 0 + IF( NCNVRG ) + $ INFO = INFO + 1 + IF( TOOFEW ) + $ INFO = INFO + 2 + RETURN +* +* End of DSTEBZ +* + END diff --git a/math/lapack/src/main/fortran/dstedc.f b/math/lapack/src/main/fortran/dstedc.f new file mode 100644 index 0000000000..d7f953729c --- /dev/null +++ b/math/lapack/src/main/fortran/dstedc.f @@ -0,0 +1,483 @@ +*> \brief \b DSTEDC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSTEDC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, +* LIWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER COMPZ +* INTEGER INFO, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSTEDC computes all eigenvalues and, optionally, eigenvectors of a +*> symmetric tridiagonal matrix using the divide and conquer method. +*> The eigenvectors of a full or band real symmetric matrix can also be +*> found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this +*> matrix to tridiagonal form. +*> +*> This code makes very mild assumptions about floating point +*> arithmetic. It will work on machines with a guard digit in +*> add/subtract, or on those binary machines without guard digits +*> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. +*> It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. See DLAED3 for details. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] COMPZ +*> \verbatim +*> COMPZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only. +*> = 'I': Compute eigenvectors of tridiagonal matrix also. +*> = 'V': Compute eigenvectors of original dense symmetric +*> matrix also. On entry, Z contains the orthogonal +*> matrix used to reduce the original matrix to +*> tridiagonal form. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The dimension of the symmetric tridiagonal matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the diagonal elements of the tridiagonal matrix. +*> On exit, if INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> On entry, the subdiagonal elements of the tridiagonal matrix. +*> On exit, E has been destroyed. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1. +*> If eigenvectors are desired, then LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, +*> dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If COMPZ = 'N' or N <= 1 then LWORK must be at least 1. +*> If COMPZ = 'V' and N > 1 then LWORK must be at least +*> ( 1 + 3*N + 2*N*lg N + 4*N**2 ), +*> where lg( N ) = smallest integer k such +*> that 2**k >= N. +*> If COMPZ = 'I' and N > 1 then LWORK must be at least +*> ( 1 + 4*N + N**2 ). +*> Note that for COMPZ = 'I' or 'V', then if N is less than or +*> equal to the minimum divide size, usually 25, then LWORK need +*> only be max(1,2*(N-1)). +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. +*> If COMPZ = 'V' and N > 1 then LIWORK must be at least +*> ( 6 + 6*N + 5*N*lg N ). +*> If COMPZ = 'I' and N > 1 then LIWORK must be at least +*> ( 3 + 5*N ). +*> Note that for COMPZ = 'I' or 'V', then if N is less than or +*> equal to the minimum divide size, usually 25, then LIWORK +*> need only be 1. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal size of the IWORK array, +*> returns this value as the first entry of the IWORK array, and +*> no error message related to LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: The algorithm failed to compute an eigenvalue while +*> working on the submatrix lying in rows and columns +*> INFO/(N+1) through mod(INFO,N+1). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Jeff Rutter, Computer Science Division, University of California +*> at Berkeley, USA \n +*> Modified by Francoise Tisseur, University of Tennessee +*> +* ===================================================================== + SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, + $ LIWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER COMPZ + INTEGER INFO, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN, + $ LWMIN, M, SMLSIZ, START, STOREZ, STRTRW + DOUBLE PRECISION EPS, ORGNRM, P, TINY +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANST + EXTERNAL LSAME, ILAENV, DLAMCH, DLANST +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLAED0, DLASCL, DLASET, DLASRT, + $ DSTEQR, DSTERF, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + 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.EQ.0 ) THEN +* +* Compute the workspace requirements +* + SMLSIZ = ILAENV( 9, 'DSTEDC', ' ', 0, 0, 0, 0 ) + IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN + LIWMIN = 1 + LWMIN = 1 + ELSE IF( N.LE.SMLSIZ ) THEN + LIWMIN = 1 + LWMIN = 2*( N - 1 ) + ELSE + LGN = INT( LOG( DBLE( N ) )/LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( ICOMPZ.EQ.1 ) THEN + LWMIN = 1 + 3*N + 2*N*LGN + 4*N**2 + LIWMIN = 6 + 6*N + 5*N*LGN + ELSE IF( ICOMPZ.EQ.2 ) THEN + LWMIN = 1 + 4*N + N**2 + LIWMIN = 3 + 5*N + END IF + END IF + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT. LQUERY ) THEN + INFO = -8 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT. LQUERY ) THEN + INFO = -10 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSTEDC', -INFO ) + RETURN + ELSE IF (LQUERY) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + IF( N.EQ.1 ) THEN + IF( ICOMPZ.NE.0 ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* If the following conditional clause is removed, then the routine +* will use the Divide and Conquer routine to compute only the +* eigenvalues, which requires (3N + 3N**2) real workspace and +* (2 + 5N + 2N lg(N)) integer workspace. +* Since on many architectures DSTERF is much faster than any other +* algorithm for finding eigenvalues only, it is used here +* as the default. If the conditional clause is removed, then +* information on the size of workspace needs to be changed. +* +* If COMPZ = 'N', use DSTERF to compute the eigenvalues. +* + IF( ICOMPZ.EQ.0 ) THEN + CALL DSTERF( N, D, E, INFO ) + GO TO 50 + END IF +* +* If N is smaller than the minimum divide size (SMLSIZ+1), then +* solve the problem with another solver. +* + IF( N.LE.SMLSIZ ) THEN +* + CALL DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) +* + ELSE +* +* If COMPZ = 'V', the Z matrix must be stored elsewhere for later +* use. +* + IF( ICOMPZ.EQ.1 ) THEN + STOREZ = 1 + N*N + ELSE + STOREZ = 1 + END IF +* + IF( ICOMPZ.EQ.2 ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) + END IF +* +* Scale. +* + ORGNRM = DLANST( 'M', N, D, E ) + IF( ORGNRM.EQ.ZERO ) + $ GO TO 50 +* + EPS = DLAMCH( 'Epsilon' ) +* + START = 1 +* +* while ( START <= N ) +* + 10 CONTINUE + IF( START.LE.N ) THEN +* +* Let FINISH be the position of the next subdiagonal entry +* such that E( FINISH ) <= TINY or FINISH = N if no such +* subdiagonal exists. The matrix identified by the elements +* between START and FINISH constitutes an independent +* sub-problem. +* + FINISH = START + 20 CONTINUE + IF( FINISH.LT.N ) THEN + TINY = EPS*SQRT( ABS( D( FINISH ) ) )* + $ SQRT( ABS( D( FINISH+1 ) ) ) + IF( ABS( E( FINISH ) ).GT.TINY ) THEN + FINISH = FINISH + 1 + GO TO 20 + END IF + END IF +* +* (Sub) Problem determined. Compute its size and solve it. +* + M = FINISH - START + 1 + IF( M.EQ.1 ) THEN + START = FINISH + 1 + GO TO 10 + END IF + IF( M.GT.SMLSIZ ) THEN +* +* Scale. +* + ORGNRM = DLANST( 'M', M, D( START ), E( START ) ) + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M, + $ INFO ) + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ), + $ M-1, INFO ) +* + IF( ICOMPZ.EQ.1 ) THEN + STRTRW = 1 + ELSE + STRTRW = START + END IF + CALL DLAED0( ICOMPZ, N, M, D( START ), E( START ), + $ Z( STRTRW, START ), LDZ, WORK( 1 ), N, + $ WORK( STOREZ ), IWORK, INFO ) + IF( INFO.NE.0 ) THEN + INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) + + $ MOD( INFO, ( M+1 ) ) + START - 1 + GO TO 50 + END IF +* +* Scale back. +* + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M, + $ INFO ) +* + ELSE + IF( ICOMPZ.EQ.1 ) THEN +* +* Since QR won't update a Z matrix which is larger than +* the length of D, we must solve the sub-problem in a +* workspace and then multiply back into Z. +* + CALL DSTEQR( 'I', M, D( START ), E( START ), WORK, M, + $ WORK( M*M+1 ), INFO ) + CALL DLACPY( 'A', N, M, Z( 1, START ), LDZ, + $ WORK( STOREZ ), N ) + CALL DGEMM( 'N', 'N', N, M, M, ONE, + $ WORK( STOREZ ), N, WORK, M, ZERO, + $ Z( 1, START ), LDZ ) + ELSE IF( ICOMPZ.EQ.2 ) THEN + CALL DSTEQR( 'I', M, D( START ), E( START ), + $ Z( START, START ), LDZ, WORK, INFO ) + ELSE + CALL DSTERF( M, D( START ), E( START ), INFO ) + END IF + IF( INFO.NE.0 ) THEN + INFO = START*( N+1 ) + FINISH + GO TO 50 + END IF + END IF +* + START = FINISH + 1 + GO TO 10 + END IF +* +* endwhile +* + IF( ICOMPZ.EQ.0 ) THEN +* +* Use Quick Sort +* + CALL DLASRT( 'I', N, D, INFO ) +* + ELSE +* +* Use Selection Sort to minimize swaps of eigenvectors +* + DO 40 II = 2, N + I = II - 1 + K = I + P = D( I ) + DO 30 J = II, N + IF( D( J ).LT.P ) THEN + K = J + P = D( J ) + END IF + 30 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 + 40 CONTINUE + END IF + END IF +* + 50 CONTINUE + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of DSTEDC +* + END diff --git a/math/lapack/src/main/fortran/dstegr.f b/math/lapack/src/main/fortran/dstegr.f new file mode 100644 index 0000000000..f32860322e --- /dev/null +++ b/math/lapack/src/main/fortran/dstegr.f @@ -0,0 +1,302 @@ +*> \brief \b DSTEGR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSTEGR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, +* ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, +* LIWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE +* INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER ISUPPZ( * ), IWORK( * ) +* DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) +* DOUBLE PRECISION Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSTEGR computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric tridiagonal matrix T. Any such unreduced matrix has +*> a well defined set of pairwise different real eigenvalues, the corresponding +*> real eigenvectors are pairwise orthogonal. +*> +*> The spectrum may be computed either completely or partially by specifying +*> either an interval (VL,VU] or a range of indices IL:IU for the desired +*> eigenvalues. +*> +*> DSTEGR is a compatibility wrapper around the improved DSTEMR routine. +*> See DSTEMR for further details. +*> +*> One important change is that the ABSTOL parameter no longer provides any +*> benefit and hence is no longer used. +*> +*> Note : DSTEGR and DSTEMR work only on machines which follow +*> IEEE-754 floating-point standard in their handling of infinities and +*> NaNs. Normal execution may create these exceptiona values and hence +*> may abort due to a floating point exception in environments which +*> do not conform to the IEEE-754 standard. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the N diagonal elements of the tridiagonal matrix +*> T. On exit, D is overwritten. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On entry, the (N-1) subdiagonal elements of the tridiagonal +*> matrix T in elements 1 to N-1 of E. E(N) need not be set on +*> input, but is used internally as workspace. +*> On exit, E is overwritten. +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> Unused. Was the absolute error tolerance for the +*> eigenvalues/eigenvectors in previous versions. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first M elements contain the selected eigenvalues in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) +*> If JOBZ = 'V', and if INFO = 0, then the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix T +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> Supplying N columns is always safe. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', then LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] ISUPPZ +*> \verbatim +*> ISUPPZ is INTEGER ARRAY, dimension ( 2*max(1,M) ) +*> The support of the eigenvectors in Z, i.e., the indices +*> indicating the nonzero elements in Z. The i-th computed eigenvector +*> is nonzero only in elements ISUPPZ( 2*i-1 ) through +*> ISUPPZ( 2*i ). This is relevant in the case when the matrix +*> is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal +*> (and minimal) LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= max(1,18*N) +*> if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (LIWORK) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. LIWORK >= max(1,10*N) +*> if the eigenvectors are desired, and LIWORK >= max(1,8*N) +*> if only the eigenvalues are to be computed. +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal size of the IWORK array, +*> returns this value as the first entry of the IWORK array, and +*> no error message related to LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> On exit, INFO +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = 1X, internal error in DLARRE, +*> if INFO = 2X, internal error in DLARRV. +*> Here, the digit X = ABS( IINFO ) < 10, where IINFO is +*> the nonzero error code returned by DLARRE or +*> DLARRV, respectively. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Inderjit Dhillon, IBM Almaden, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Christof Voemel, LBNL/NERSC, USA \n +* +* ===================================================================== + SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, + $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, + $ LIWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE + INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER ISUPPZ( * ), IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) + DOUBLE PRECISION Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL TRYRAC +* .. +* .. External Subroutines .. + EXTERNAL DSTEMR +* .. +* .. Executable Statements .. + INFO = 0 + TRYRAC = .FALSE. + + CALL DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, + $ M, W, Z, LDZ, N, ISUPPZ, TRYRAC, WORK, LWORK, + $ IWORK, LIWORK, INFO ) +* +* End of DSTEGR +* + END diff --git a/math/lapack/src/main/fortran/dstein.f b/math/lapack/src/main/fortran/dstein.f new file mode 100644 index 0000000000..fb1e8b9fd5 --- /dev/null +++ b/math/lapack/src/main/fortran/dstein.f @@ -0,0 +1,453 @@ +*> \brief \b DSTEIN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSTEIN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, +* IWORK, IFAIL, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDZ, M, N +* .. +* .. Array Arguments .. +* INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ), +* $ IWORK( * ) +* DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSTEIN computes the eigenvectors of a real symmetric tridiagonal +*> matrix T corresponding to specified eigenvalues, using inverse +*> iteration. +*> +*> The maximum number of iterations allowed for each eigenvector is +*> specified by an internal parameter MAXITS (currently set to 5). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The n diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) subdiagonal elements of the tridiagonal matrix +*> T, in elements 1 to N-1. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of eigenvectors to be found. 0 <= M <= N. +*> \endverbatim +*> +*> \param[in] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first M elements of W contain the eigenvalues for +*> which eigenvectors are to be computed. The eigenvalues +*> should be grouped by split-off block and ordered from +*> smallest to largest within the block. ( The output array +*> W from DSTEBZ with ORDER = 'B' is expected here. ) +*> \endverbatim +*> +*> \param[in] IBLOCK +*> \verbatim +*> IBLOCK is INTEGER array, dimension (N) +*> The submatrix indices associated with the corresponding +*> eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to +*> the first submatrix from the top, =2 if W(i) belongs to +*> the second submatrix, etc. ( The output array IBLOCK +*> from DSTEBZ is expected here. ) +*> \endverbatim +*> +*> \param[in] ISPLIT +*> \verbatim +*> ISPLIT is INTEGER array, dimension (N) +*> The splitting points, at which T breaks up into submatrices. +*> The first submatrix consists of rows/columns 1 to +*> ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 +*> through ISPLIT( 2 ), etc. +*> ( The output array ISPLIT from DSTEBZ is expected here. ) +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, M) +*> The computed eigenvectors. The eigenvector associated +*> with the eigenvalue W(i) is stored in the i-th column of +*> Z. Any vector which fails to converge is set to its current +*> iterate after MAXITS iterations. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (M) +*> On normal exit, all elements of IFAIL are zero. +*> If one or more eigenvectors fail to converge after +*> MAXITS iterations, then their indices are stored in +*> array IFAIL. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, then i eigenvectors failed to converge +*> in MAXITS iterations. Their indices are stored in +*> array IFAIL. +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> MAXITS INTEGER, default = 5 +*> The maximum number of iterations performed. +*> +*> EXTRA INTEGER, default = 2 +*> The number of iterations performed after norm growth +*> criterion is satisfied, should be at least 1. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, + $ IWORK, IFAIL, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDZ, M, N +* .. +* .. Array Arguments .. + INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ), + $ IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1 + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1, + $ ODM3 = 1.0D-3, ODM1 = 1.0D-1 ) + INTEGER MAXITS, EXTRA + PARAMETER ( MAXITS = 5, EXTRA = 2 ) +* .. +* .. Local Scalars .. + INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1, + $ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1, + $ JBLK, JMAX, NBLK, NRMCHK + DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL, + $ SCL, SEP, TOL, XJ, XJM, ZTR +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DDOT, DLAMCH, DNRM2 + EXTERNAL IDAMAX, DDOT, DLAMCH, DNRM2 +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + DO 10 I = 1, M + IFAIL( I ) = 0 + 10 CONTINUE +* + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 .OR. M.GT.N ) THEN + INFO = -4 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE + DO 20 J = 2, M + IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN + INFO = -6 + GO TO 30 + END IF + IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) ) + $ THEN + INFO = -5 + GO TO 30 + END IF + 20 CONTINUE + 30 CONTINUE + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSTEIN', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. M.EQ.0 ) THEN + RETURN + ELSE IF( N.EQ.1 ) THEN + Z( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + EPS = DLAMCH( 'Precision' ) +* +* Initialize seed for random number generator DLARNV. +* + DO 40 I = 1, 4 + ISEED( I ) = 1 + 40 CONTINUE +* +* Initialize pointers. +* + INDRV1 = 0 + INDRV2 = INDRV1 + N + INDRV3 = INDRV2 + N + INDRV4 = INDRV3 + N + INDRV5 = INDRV4 + N +* +* Compute eigenvectors of matrix blocks. +* + J1 = 1 + DO 160 NBLK = 1, IBLOCK( M ) +* +* Find starting and ending indices of block nblk. +* + IF( NBLK.EQ.1 ) THEN + B1 = 1 + ELSE + B1 = ISPLIT( NBLK-1 ) + 1 + END IF + BN = ISPLIT( NBLK ) + BLKSIZ = BN - B1 + 1 + IF( BLKSIZ.EQ.1 ) + $ GO TO 60 + GPIND = J1 +* +* Compute reorthogonalization criterion and stopping criterion. +* + ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) ) + ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) ) + DO 50 I = B1 + 1, BN - 1 + ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+ + $ ABS( E( I ) ) ) + 50 CONTINUE + ORTOL = ODM3*ONENRM +* + DTPCRT = SQRT( ODM1 / BLKSIZ ) +* +* Loop through eigenvalues of block nblk. +* + 60 CONTINUE + JBLK = 0 + DO 150 J = J1, M + IF( IBLOCK( J ).NE.NBLK ) THEN + J1 = J + GO TO 160 + END IF + JBLK = JBLK + 1 + XJ = W( J ) +* +* Skip all the work if the block size is one. +* + IF( BLKSIZ.EQ.1 ) THEN + WORK( INDRV1+1 ) = ONE + GO TO 120 + END IF +* +* If eigenvalues j and j-1 are too close, add a relatively +* small perturbation. +* + IF( JBLK.GT.1 ) THEN + EPS1 = ABS( EPS*XJ ) + PERTOL = TEN*EPS1 + SEP = XJ - XJM + IF( SEP.LT.PERTOL ) + $ XJ = XJM + PERTOL + END IF +* + ITS = 0 + NRMCHK = 0 +* +* Get random starting vector. +* + CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) ) +* +* Copy the matrix T so it won't be destroyed in factorization. +* + CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 ) + CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 ) + CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 ) +* +* Compute LU factors with partial pivoting ( PT = LU ) +* + TOL = ZERO + CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ), + $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK, + $ IINFO ) +* +* Update iteration count. +* + 70 CONTINUE + ITS = ITS + 1 + IF( ITS.GT.MAXITS ) + $ GO TO 100 +* +* Normalize and scale the righthand side vector Pb. +* + JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) + SCL = BLKSIZ*ONENRM*MAX( EPS, + $ ABS( WORK( INDRV4+BLKSIZ ) ) ) / + $ ABS( WORK( INDRV1+JMAX ) ) + CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) +* +* Solve the system LU = Pb. +* + CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ), + $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK, + $ WORK( INDRV1+1 ), TOL, IINFO ) +* +* Reorthogonalize by modified Gram-Schmidt if eigenvalues are +* close enough. +* + IF( JBLK.EQ.1 ) + $ GO TO 90 + IF( ABS( XJ-XJM ).GT.ORTOL ) + $ GPIND = J + IF( GPIND.NE.J ) THEN + DO 80 I = GPIND, J - 1 + ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ), + $ 1 ) + CALL DAXPY( BLKSIZ, ZTR, Z( B1, I ), 1, + $ WORK( INDRV1+1 ), 1 ) + 80 CONTINUE + END IF +* +* Check the infinity norm of the iterate. +* + 90 CONTINUE + JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) + NRM = ABS( WORK( INDRV1+JMAX ) ) +* +* Continue for additional iterations after norm reaches +* stopping criterion. +* + IF( NRM.LT.DTPCRT ) + $ GO TO 70 + NRMCHK = NRMCHK + 1 + IF( NRMCHK.LT.EXTRA+1 ) + $ GO TO 70 +* + GO TO 110 +* +* If stopping criterion was not satisfied, update info and +* store eigenvector number in array ifail. +* + 100 CONTINUE + INFO = INFO + 1 + IFAIL( INFO ) = J +* +* Accept iterate as jth eigenvector. +* + 110 CONTINUE + SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 ) + JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) + IF( WORK( INDRV1+JMAX ).LT.ZERO ) + $ SCL = -SCL + CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) + 120 CONTINUE + DO 130 I = 1, N + Z( I, J ) = ZERO + 130 CONTINUE + DO 140 I = 1, BLKSIZ + Z( B1+I-1, J ) = WORK( INDRV1+I ) + 140 CONTINUE +* +* Save the shift to check eigenvalue spacing at next +* iteration. +* + XJM = XJ +* + 150 CONTINUE + 160 CONTINUE +* + RETURN +* +* End of DSTEIN +* + END diff --git a/math/lapack/src/main/fortran/dstemr.f b/math/lapack/src/main/fortran/dstemr.f new file mode 100644 index 0000000000..924d738d04 --- /dev/null +++ b/math/lapack/src/main/fortran/dstemr.f @@ -0,0 +1,777 @@ +*> \brief \b DSTEMR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSTEMR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, +* M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, +* IWORK, LIWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE +* LOGICAL TRYRAC +* INTEGER IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N +* DOUBLE PRECISION VL, VU +* .. +* .. Array Arguments .. +* INTEGER ISUPPZ( * ), IWORK( * ) +* DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) +* DOUBLE PRECISION Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSTEMR computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric tridiagonal matrix T. Any such unreduced matrix has +*> a well defined set of pairwise different real eigenvalues, the corresponding +*> real eigenvectors are pairwise orthogonal. +*> +*> The spectrum may be computed either completely or partially by specifying +*> either an interval (VL,VU] or a range of indices IL:IU for the desired +*> eigenvalues. +*> +*> Depending on the number of desired eigenvalues, these are computed either +*> by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are +*> computed by the use of various suitable L D L^T factorizations near clusters +*> of close eigenvalues (referred to as RRRs, Relatively Robust +*> Representations). An informal sketch of the algorithm follows. +*> +*> For each unreduced block (submatrix) of T, +*> (a) Compute T - sigma I = L D L^T, so that L and D +*> define all the wanted eigenvalues to high relative accuracy. +*> This means that small relative changes in the entries of D and L +*> cause only small relative changes in the eigenvalues and +*> eigenvectors. The standard (unfactored) representation of the +*> tridiagonal matrix T does not have this property in general. +*> (b) Compute the eigenvalues to suitable accuracy. +*> If the eigenvectors are desired, the algorithm attains full +*> accuracy of the computed eigenvalues only right before +*> the corresponding vectors have to be computed, see steps c) and d). +*> (c) For each cluster of close eigenvalues, select a new +*> shift close to the cluster, find a new factorization, and refine +*> the shifted eigenvalues to suitable accuracy. +*> (d) For each eigenvalue with a large enough relative separation compute +*> the corresponding eigenvector by forming a rank revealing twisted +*> factorization. Go back to (c) for any clusters that remain. +*> +*> For more details, see: +*> - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations +*> to compute orthogonal eigenvectors of symmetric tridiagonal matrices," +*> Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. +*> - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and +*> Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, +*> 2004. Also LAPACK Working Note 154. +*> - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric +*> tridiagonal eigenvalue/eigenvector problem", +*> Computer Science Division Technical Report No. UCB/CSD-97-971, +*> UC Berkeley, May 1997. +*> +*> Further Details +*> 1.DSTEMR works only on machines which follow IEEE-754 +*> floating-point standard in their handling of infinities and NaNs. +*> This permits the use of efficient inner loops avoiding a check for +*> zero divisors. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the N diagonal elements of the tridiagonal matrix +*> T. On exit, D is overwritten. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On entry, the (N-1) subdiagonal elements of the tridiagonal +*> matrix T in elements 1 to N-1 of E. E(N) need not be set on +*> input, but is used internally as workspace. +*> On exit, E is overwritten. +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first M elements contain the selected eigenvalues in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) +*> If JOBZ = 'V', and if INFO = 0, then the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix T +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and can be computed with a workspace +*> query by setting NZC = -1, see below. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', then LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[in] NZC +*> \verbatim +*> NZC is INTEGER +*> The number of eigenvectors to be held in the array Z. +*> If RANGE = 'A', then NZC >= max(1,N). +*> If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. +*> If RANGE = 'I', then NZC >= IU-IL+1. +*> If NZC = -1, then a workspace query is assumed; the +*> routine calculates the number of columns of the array Z that +*> are needed to hold the eigenvectors. +*> This value is returned as the first entry of the Z array, and +*> no error message related to NZC is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] ISUPPZ +*> \verbatim +*> ISUPPZ is INTEGER ARRAY, dimension ( 2*max(1,M) ) +*> The support of the eigenvectors in Z, i.e., the indices +*> indicating the nonzero elements in Z. The i-th computed eigenvector +*> is nonzero only in elements ISUPPZ( 2*i-1 ) through +*> ISUPPZ( 2*i ). This is relevant in the case when the matrix +*> is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. +*> \endverbatim +*> +*> \param[in,out] TRYRAC +*> \verbatim +*> TRYRAC is LOGICAL +*> If TRYRAC.EQ..TRUE., indicates that the code should check whether +*> the tridiagonal matrix defines its eigenvalues to high relative +*> accuracy. If so, the code uses relative-accuracy preserving +*> algorithms that might be (a bit) slower depending on the matrix. +*> If the matrix does not define its eigenvalues to high relative +*> accuracy, the code can uses possibly faster algorithms. +*> If TRYRAC.EQ..FALSE., the code is not required to guarantee +*> relatively accurate eigenvalues and can use the fastest possible +*> techniques. +*> On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix +*> does not define its eigenvalues to high relative accuracy. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal +*> (and minimal) LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= max(1,18*N) +*> if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (LIWORK) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. LIWORK >= max(1,10*N) +*> if the eigenvectors are desired, and LIWORK >= max(1,8*N) +*> if only the eigenvalues are to be computed. +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal size of the IWORK array, +*> returns this value as the first entry of the IWORK array, and +*> no error message related to LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> On exit, INFO +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = 1X, internal error in DLARRE, +*> if INFO = 2X, internal error in DLARRV. +*> Here, the digit X = ABS( IINFO ) < 10, where IINFO is +*> the nonzero error code returned by DLARRE or +*> DLARRV, respectively. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Beresford Parlett, University of California, Berkeley, USA \n +*> Jim Demmel, University of California, Berkeley, USA \n +*> Inderjit Dhillon, University of Texas, Austin, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Christof Voemel, University of California, Berkeley, USA +* +* ===================================================================== + SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, + $ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, + $ IWORK, LIWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE + LOGICAL TRYRAC + INTEGER IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N + DOUBLE PRECISION VL, VU +* .. +* .. Array Arguments .. + INTEGER ISUPPZ( * ), IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) + DOUBLE PRECISION Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, FOUR, MINRGP + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, + $ FOUR = 4.0D0, + $ MINRGP = 1.0D-3 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY + INTEGER I, IBEGIN, IEND, IFIRST, IIL, IINDBL, IINDW, + $ IINDWK, IINFO, IINSPL, IIU, ILAST, IN, INDD, + $ INDE2, INDERR, INDGP, INDGRS, INDWRK, ITMP, + $ ITMP2, J, JBLK, JJ, LIWMIN, LWMIN, NSPLIT, + $ NZCMIN, OFFSET, WBEGIN, WEND + DOUBLE PRECISION BIGNUM, CS, EPS, PIVMIN, R1, R2, RMAX, RMIN, + $ RTOL1, RTOL2, SAFMIN, SCALE, SMLNUM, SN, + $ THRESH, TMP, TNRM, WL, WU +* .. +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANST + EXTERNAL LSAME, DLAMCH, DLANST +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLAE2, DLAEV2, DLARRC, DLARRE, DLARRJ, + $ DLARRR, DLARRV, DLASRT, DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT + + +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) +* + LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) ) + ZQUERY = ( NZC.EQ.-1 ) + +* DSTEMR needs WORK of size 6*N, IWORK of size 3*N. +* In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N. +* Furthermore, DLARRV needs WORK of size 12*N, IWORK of size 7*N. + IF( WANTZ ) THEN + LWMIN = 18*N + LIWMIN = 10*N + ELSE +* need less workspace if only the eigenvalues are wanted + LWMIN = 12*N + LIWMIN = 8*N + ENDIF + + WL = ZERO + WU = ZERO + IIL = 0 + IIU = 0 + NSPLIT = 0 + + IF( VALEIG ) THEN +* We do not reference VL, VU in the cases RANGE = 'I','A' +* The interval (WL, WU] contains all the wanted eigenvalues. +* It is either given by the user or computed in DLARRE. + WL = VL + WU = VU + ELSEIF( INDEIG ) THEN +* We do not reference IL, IU in the cases RANGE = 'V','A' + IIL = IL + IIU = IU + ENDIF +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( VALEIG .AND. N.GT.0 .AND. WU.LE.WL ) THEN + INFO = -7 + ELSE IF( INDEIG .AND. ( IIL.LT.1 .OR. IIL.GT.N ) ) THEN + INFO = -8 + ELSE IF( INDEIG .AND. ( IIU.LT.IIL .OR. IIU.GT.N ) ) THEN + INFO = -9 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -13 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -17 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -19 + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + IF( WANTZ .AND. ALLEIG ) THEN + NZCMIN = N + ELSE IF( WANTZ .AND. VALEIG ) THEN + CALL DLARRC( 'T', N, VL, VU, D, E, SAFMIN, + $ NZCMIN, ITMP, ITMP2, INFO ) + ELSE IF( WANTZ .AND. INDEIG ) THEN + NZCMIN = IIU-IIL+1 + ELSE +* WANTZ .EQ. FALSE. + NZCMIN = 0 + ENDIF + IF( ZQUERY .AND. INFO.EQ.0 ) THEN + Z( 1,1 ) = NZCMIN + ELSE IF( NZC.LT.NZCMIN .AND. .NOT.ZQUERY ) THEN + INFO = -14 + END IF + END IF + + IF( INFO.NE.0 ) THEN +* + CALL XERBLA( 'DSTEMR', -INFO ) +* + RETURN + ELSE IF( LQUERY .OR. ZQUERY ) THEN + RETURN + END IF +* +* Handle N = 0, 1, and 2 cases immediately +* + M = 0 + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = D( 1 ) + ELSE + IF( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN + M = 1 + W( 1 ) = D( 1 ) + END IF + END IF + IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN + Z( 1, 1 ) = ONE + ISUPPZ(1) = 1 + ISUPPZ(2) = 1 + END IF + RETURN + END IF +* + IF( N.EQ.2 ) THEN + IF( .NOT.WANTZ ) THEN + CALL DLAE2( D(1), E(1), D(2), R1, R2 ) + ELSE IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN + CALL DLAEV2( D(1), E(1), D(2), R1, R2, CS, SN ) + END IF + IF( ALLEIG.OR. + $ (VALEIG.AND.(R2.GT.WL).AND. + $ (R2.LE.WU)).OR. + $ (INDEIG.AND.(IIL.EQ.1)) ) THEN + M = M+1 + W( M ) = R2 + IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN + Z( 1, M ) = -SN + Z( 2, M ) = CS +* Note: At most one of SN and CS can be zero. + IF (SN.NE.ZERO) THEN + IF (CS.NE.ZERO) THEN + ISUPPZ(2*M-1) = 1 + ISUPPZ(2*M) = 2 + ELSE + ISUPPZ(2*M-1) = 1 + ISUPPZ(2*M) = 1 + END IF + ELSE + ISUPPZ(2*M-1) = 2 + ISUPPZ(2*M) = 2 + END IF + ENDIF + ENDIF + IF( ALLEIG.OR. + $ (VALEIG.AND.(R1.GT.WL).AND. + $ (R1.LE.WU)).OR. + $ (INDEIG.AND.(IIU.EQ.2)) ) THEN + M = M+1 + W( M ) = R1 + IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN + Z( 1, M ) = CS + Z( 2, M ) = SN +* Note: At most one of SN and CS can be zero. + IF (SN.NE.ZERO) THEN + IF (CS.NE.ZERO) THEN + ISUPPZ(2*M-1) = 1 + ISUPPZ(2*M) = 2 + ELSE + ISUPPZ(2*M-1) = 1 + ISUPPZ(2*M) = 1 + END IF + ELSE + ISUPPZ(2*M-1) = 2 + ISUPPZ(2*M) = 2 + END IF + ENDIF + ENDIF + + ELSE + +* Continue with general N + + INDGRS = 1 + INDERR = 2*N + 1 + INDGP = 3*N + 1 + INDD = 4*N + 1 + INDE2 = 5*N + 1 + INDWRK = 6*N + 1 +* + IINSPL = 1 + IINDBL = N + 1 + IINDW = 2*N + 1 + IINDWK = 3*N + 1 +* +* Scale matrix to allowable range, if necessary. +* The allowable range is related to the PIVMIN parameter; see the +* comments in DLARRD. The preference for scaling small values +* up is heuristic; we expect users' matrices not to be close to the +* RMAX threshold. +* + SCALE = ONE + TNRM = DLANST( 'M', N, D, E ) + IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN + SCALE = RMIN / TNRM + ELSE IF( TNRM.GT.RMAX ) THEN + SCALE = RMAX / TNRM + END IF + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( N, SCALE, D, 1 ) + CALL DSCAL( N-1, SCALE, E, 1 ) + TNRM = TNRM*SCALE + IF( VALEIG ) THEN +* If eigenvalues in interval have to be found, +* scale (WL, WU] accordingly + WL = WL*SCALE + WU = WU*SCALE + ENDIF + END IF +* +* Compute the desired eigenvalues of the tridiagonal after splitting +* into smaller subblocks if the corresponding off-diagonal elements +* are small +* THRESH is the splitting parameter for DLARRE +* A negative THRESH forces the old splitting criterion based on the +* size of the off-diagonal. A positive THRESH switches to splitting +* which preserves relative accuracy. +* + IF( TRYRAC ) THEN +* Test whether the matrix warrants the more expensive relative approach. + CALL DLARRR( N, D, E, IINFO ) + ELSE +* The user does not care about relative accurately eigenvalues + IINFO = -1 + ENDIF +* Set the splitting criterion + IF (IINFO.EQ.0) THEN + THRESH = EPS + ELSE + THRESH = -EPS +* relative accuracy is desired but T does not guarantee it + TRYRAC = .FALSE. + ENDIF +* + IF( TRYRAC ) THEN +* Copy original diagonal, needed to guarantee relative accuracy + CALL DCOPY(N,D,1,WORK(INDD),1) + ENDIF +* Store the squares of the offdiagonal values of T + DO 5 J = 1, N-1 + WORK( INDE2+J-1 ) = E(J)**2 + 5 CONTINUE + +* Set the tolerance parameters for bisection + IF( .NOT.WANTZ ) THEN +* DLARRE computes the eigenvalues to full precision. + RTOL1 = FOUR * EPS + RTOL2 = FOUR * EPS + ELSE +* DLARRE computes the eigenvalues to less than full precision. +* DLARRV will refine the eigenvalue approximations, and we can +* need less accurate initial bisection in DLARRE. +* Note: these settings do only affect the subset case and DLARRE + RTOL1 = SQRT(EPS) + RTOL2 = MAX( SQRT(EPS)*5.0D-3, FOUR * EPS ) + ENDIF + CALL DLARRE( RANGE, N, WL, WU, IIL, IIU, D, E, + $ WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT, + $ IWORK( IINSPL ), M, W, WORK( INDERR ), + $ WORK( INDGP ), IWORK( IINDBL ), + $ IWORK( IINDW ), WORK( INDGRS ), PIVMIN, + $ WORK( INDWRK ), IWORK( IINDWK ), IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = 10 + ABS( IINFO ) + RETURN + END IF +* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired +* part of the spectrum. All desired eigenvalues are contained in +* (WL,WU] + + + IF( WANTZ ) THEN +* +* Compute the desired eigenvectors corresponding to the computed +* eigenvalues +* + CALL DLARRV( N, WL, WU, D, E, + $ PIVMIN, IWORK( IINSPL ), M, + $ 1, M, MINRGP, RTOL1, RTOL2, + $ W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ), + $ IWORK( IINDW ), WORK( INDGRS ), Z, LDZ, + $ ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ), IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = 20 + ABS( IINFO ) + RETURN + END IF + ELSE +* DLARRE computes eigenvalues of the (shifted) root representation +* DLARRV returns the eigenvalues of the unshifted matrix. +* However, if the eigenvectors are not desired by the user, we need +* to apply the corresponding shifts from DLARRE to obtain the +* eigenvalues of the original matrix. + DO 20 J = 1, M + ITMP = IWORK( IINDBL+J-1 ) + W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) ) + 20 CONTINUE + END IF +* + + IF ( TRYRAC ) THEN +* Refine computed eigenvalues so that they are relatively accurate +* with respect to the original matrix T. + IBEGIN = 1 + WBEGIN = 1 + DO 39 JBLK = 1, IWORK( IINDBL+M-1 ) + IEND = IWORK( IINSPL+JBLK-1 ) + IN = IEND - IBEGIN + 1 + WEND = WBEGIN - 1 +* check if any eigenvalues have to be refined in this block + 36 CONTINUE + IF( WEND.LT.M ) THEN + IF( IWORK( IINDBL+WEND ).EQ.JBLK ) THEN + WEND = WEND + 1 + GO TO 36 + END IF + END IF + IF( WEND.LT.WBEGIN ) THEN + IBEGIN = IEND + 1 + GO TO 39 + END IF + + OFFSET = IWORK(IINDW+WBEGIN-1)-1 + IFIRST = IWORK(IINDW+WBEGIN-1) + ILAST = IWORK(IINDW+WEND-1) + RTOL2 = FOUR * EPS + CALL DLARRJ( IN, + $ WORK(INDD+IBEGIN-1), WORK(INDE2+IBEGIN-1), + $ IFIRST, ILAST, RTOL2, OFFSET, W(WBEGIN), + $ WORK( INDERR+WBEGIN-1 ), + $ WORK( INDWRK ), IWORK( IINDWK ), PIVMIN, + $ TNRM, IINFO ) + IBEGIN = IEND + 1 + WBEGIN = WEND + 1 + 39 CONTINUE + ENDIF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( M, ONE / SCALE, W, 1 ) + END IF + + END IF + +* +* If eigenvalues are not in increasing order, then sort them, +* possibly along with eigenvectors. +* + IF( NSPLIT.GT.1 .OR. N.EQ.2 ) THEN + IF( .NOT. WANTZ ) THEN + CALL DLASRT( 'I', M, W, IINFO ) + IF( IINFO.NE.0 ) THEN + INFO = 3 + RETURN + END IF + ELSE + DO 60 J = 1, M - 1 + I = 0 + TMP = W( J ) + DO 50 JJ = J + 1, M + IF( W( JJ ).LT.TMP ) THEN + I = JJ + TMP = W( JJ ) + END IF + 50 CONTINUE + IF( I.NE.0 ) THEN + W( I ) = W( J ) + W( J ) = TMP + IF( WANTZ ) THEN + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + ITMP = ISUPPZ( 2*I-1 ) + ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 ) + ISUPPZ( 2*J-1 ) = ITMP + ITMP = ISUPPZ( 2*I ) + ISUPPZ( 2*I ) = ISUPPZ( 2*J ) + ISUPPZ( 2*J ) = ITMP + END IF + END IF + 60 CONTINUE + END IF + ENDIF +* +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN + RETURN +* +* End of DSTEMR +* + END diff --git a/math/lapack/src/main/fortran/dsteqr.f b/math/lapack/src/main/fortran/dsteqr.f new file mode 100644 index 0000000000..c34a548984 --- /dev/null +++ b/math/lapack/src/main/fortran/dsteqr.f @@ -0,0 +1,572 @@ +*> \brief \b DSTEQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSTEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER COMPZ +* INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] COMPZ +*> \verbatim +*> COMPZ is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the diagonal elements of the tridiagonal matrix. +*> On exit, if INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> On entry, the (n-1) subdiagonal elements of the tridiagonal +*> matrix. +*> On exit, E has been destroyed. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> eigenvectors are desired, then LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2)) +*> If COMPZ = 'N', then WORK is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER COMPZ + INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. 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( 'M', 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/math/lapack/src/main/fortran/dsterf.f b/math/lapack/src/main/fortran/dsterf.f new file mode 100644 index 0000000000..3401894819 --- /dev/null +++ b/math/lapack/src/main/fortran/dsterf.f @@ -0,0 +1,426 @@ +*> \brief \b DSTERF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSTERF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSTERF( N, D, E, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSTERF computes all eigenvalues of a symmetric tridiagonal matrix +*> using the Pal-Walker-Kahan variant of the QL or QR algorithm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is 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. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> On entry, the (n-1) subdiagonal elements of the tridiagonal +*> matrix. +*> On exit, E has been destroyed. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + SUBROUTINE DSTERF( N, D, E, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) +* .. +* +* ===================================================================== +* +* .. 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, RMAX +* .. +* .. 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 + RMAX = DLAMCH( 'O' ) +* +* 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( 'M', 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 +* + 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/math/lapack/src/main/fortran/dstev.f b/math/lapack/src/main/fortran/dstev.f new file mode 100644 index 0000000000..c59eaf3444 --- /dev/null +++ b/math/lapack/src/main/fortran/dstev.f @@ -0,0 +1,235 @@ +*> \brief DSTEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSTEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ +* INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSTEV computes all eigenvalues and, optionally, eigenvectors of a +*> real symmetric tridiagonal matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the n diagonal elements of the tridiagonal matrix +*> A. +*> On exit, if INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> On entry, the (n-1) subdiagonal elements of the tridiagonal +*> matrix A, stored in elements 1 to N-1 of E. +*> On exit, the contents of E are destroyed. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, N) +*> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal +*> eigenvectors of the matrix A, with the i-th column of Z +*> holding the eigenvector associated with D(i). +*> If JOBZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2)) +*> If JOBZ = 'N', WORK is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of E did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHEReigen +* +* ===================================================================== + SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ + INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL WANTZ + INTEGER IMAX, ISCALE + DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, + $ TNRM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANST + EXTERNAL LSAME, DLAMCH, DLANST +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, 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( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -6 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSTEV ', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + 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. +* + ISCALE = 0 + TNRM = DLANST( 'M', N, D, E ) + IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / TNRM + ELSE IF( TNRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / TNRM + END IF + IF( ISCALE.EQ.1 ) THEN + CALL DSCAL( N, SIGMA, D, 1 ) + CALL DSCAL( N-1, SIGMA, E( 1 ), 1 ) + END IF +* +* For eigenvalues only, call DSTERF. For eigenvalues and +* eigenvectors, call DSTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, D, E, INFO ) + ELSE + CALL DSTEQR( 'I', N, D, E, Z, LDZ, WORK, 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, D, 1 ) + END IF +* + RETURN +* +* End of DSTEV +* + END diff --git a/math/lapack/src/main/fortran/dstevd.f b/math/lapack/src/main/fortran/dstevd.f new file mode 100644 index 0000000000..6a07b249ed --- /dev/null +++ b/math/lapack/src/main/fortran/dstevd.f @@ -0,0 +1,302 @@ +*> \brief DSTEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSTEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, +* LIWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ +* INTEGER INFO, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSTEVD computes all eigenvalues and, optionally, eigenvectors of a +*> real symmetric tridiagonal matrix. If eigenvectors are desired, it +*> uses a divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the n diagonal elements of the tridiagonal matrix +*> A. +*> On exit, if INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> On entry, the (n-1) subdiagonal elements of the tridiagonal +*> matrix A, stored in elements 1 to N-1 of E. +*> On exit, the contents of E are destroyed. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, N) +*> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal +*> eigenvectors of the matrix A, with the i-th column of Z +*> holding the eigenvector associated with D(i). +*> If JOBZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, +*> dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If JOBZ = 'N' or N <= 1 then LWORK must be at least 1. +*> If JOBZ = 'V' and N > 1 then LWORK must be at least +*> ( 1 + 4*N + N**2 ). +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK and IWORK +*> arrays, returns these values as the first entries of the WORK +*> and IWORK arrays, and no error message related to LWORK or +*> LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1. +*> If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of E did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHEReigen +* +* ===================================================================== + SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, + $ LIWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ + INTEGER INFO, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, WANTZ + INTEGER ISCALE, LIWMIN, LWMIN + DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, + $ TNRM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANST + EXTERNAL LSAME, DLAMCH, DLANST +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSTEDC, DSTERF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + INFO = 0 + LIWMIN = 1 + LWMIN = 1 + IF( N.GT.1 .AND. WANTZ ) THEN + LWMIN = 1 + 4*N + N**2 + LIWMIN = 3 + 5*N + END IF +* + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -6 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -8 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSTEVD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + 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. +* + ISCALE = 0 + TNRM = DLANST( 'M', N, D, E ) + IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / TNRM + ELSE IF( TNRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / TNRM + END IF + IF( ISCALE.EQ.1 ) THEN + CALL DSCAL( N, SIGMA, D, 1 ) + CALL DSCAL( N-1, SIGMA, E( 1 ), 1 ) + END IF +* +* For eigenvalues only, call DSTERF. For eigenvalues and +* eigenvectors, call DSTEDC. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, D, E, INFO ) + ELSE + CALL DSTEDC( 'I', N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, + $ INFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( N, ONE / SIGMA, D, 1 ) +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of DSTEVD +* + END diff --git a/math/lapack/src/main/fortran/dstevr.f b/math/lapack/src/main/fortran/dstevr.f new file mode 100644 index 0000000000..10f1b77201 --- /dev/null +++ b/math/lapack/src/main/fortran/dstevr.f @@ -0,0 +1,584 @@ +*> \brief DSTEVR computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSTEVR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, +* M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, +* LIWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE +* INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER ISUPPZ( * ), IWORK( * ) +* DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSTEVR computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric tridiagonal matrix T. Eigenvalues and +*> eigenvectors can be selected by specifying either a range of values +*> or a range of indices for the desired eigenvalues. +*> +*> Whenever possible, DSTEVR calls DSTEMR to compute the +*> eigenspectrum using Relatively Robust Representations. DSTEMR +*> computes eigenvalues by the dqds algorithm, while orthogonal +*> eigenvectors are computed from various "good" L D L^T representations +*> (also known as Relatively Robust Representations). Gram-Schmidt +*> orthogonalization is avoided as far as possible. More specifically, +*> the various steps of the algorithm are as follows. For the i-th +*> unreduced block of T, +*> (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T +*> is a relatively robust representation, +*> (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high +*> relative accuracy by the dqds algorithm, +*> (c) If there is a cluster of close eigenvalues, "choose" sigma_i +*> close to the cluster, and go to step (a), +*> (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T, +*> compute the corresponding eigenvector by forming a +*> rank-revealing twisted factorization. +*> The desired accuracy of the output can be specified by the input +*> parameter ABSTOL. +*> +*> For more details, see "A new O(n^2) algorithm for the symmetric +*> tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon, +*> Computer Science Division Technical Report No. UCB//CSD-97-971, +*> UC Berkeley, May 1997. +*> +*> +*> Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested +*> on machines which conform to the ieee-754 floating point standard. +*> DSTEVR calls DSTEBZ and DSTEIN on non-ieee machines and +*> when partial spectrum requests are made. +*> +*> Normal execution of DSTEMR may create NaNs and infinities and +*> hence may abort due to a floating point exception in environments +*> which do not handle NaNs and infinities in the ieee standard default +*> manner. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and +*> DSTEIN are called +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the n diagonal elements of the tridiagonal matrix +*> A. +*> On exit, D may be multiplied by a constant factor chosen +*> to avoid over/underflow in computing the eigenvalues. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (max(1,N-1)) +*> On entry, the (n-1) subdiagonal elements of the tridiagonal +*> matrix A in elements 1 to N-1 of E. +*> On exit, E may be multiplied by a constant factor chosen +*> to avoid over/underflow in computing the eigenvalues. +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing A to tridiagonal form. +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> +*> If high relative accuracy is important, set ABSTOL to +*> DLAMCH( 'Safe minimum' ). Doing so will guarantee that +*> eigenvalues are computed to high relative accuracy when +*> possible in future releases. The current code does not +*> make any guarantees about high relative accuracy, but +*> future releases will. See J. Barlow and J. Demmel, +*> "Computing Accurate Eigensystems of Scaled Diagonally +*> Dominant Matrices", LAPACK Working Note #7, for a discussion +*> of which matrices define their eigenvalues to high relative +*> accuracy. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first M elements contain the selected eigenvalues in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] ISUPPZ +*> \verbatim +*> ISUPPZ is INTEGER array, dimension ( 2*max(1,M) ) +*> The support of the eigenvectors in Z, i.e., the indices +*> indicating the nonzero elements in Z. The i-th eigenvector +*> is nonzero only in elements ISUPPZ( 2*i-1 ) through +*> ISUPPZ( 2*i ). +*> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal (and +*> minimal) LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= max(1,20*N). +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK and IWORK +*> arrays, returns these values as the first entries of the WORK +*> and IWORK arrays, and no error message related to LWORK or +*> LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal (and +*> minimal) LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. LIWORK >= max(1,10*N). +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: Internal error +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHEReigen +* +*> \par Contributors: +* ================== +*> +*> Inderjit Dhillon, IBM Almaden, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Ken Stanley, Computer Science Division, University of +*> California at Berkeley, USA \n +*> +* ===================================================================== + SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, + $ M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, + $ LIWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE + INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER ISUPPZ( * ), IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, TEST, LQUERY, VALEIG, WANTZ, + $ TRYRAC + CHARACTER ORDER + INTEGER I, IEEEOK, IMAX, INDIBL, INDIFL, INDISP, + $ INDIWO, ISCALE, ITMP1, J, JJ, LIWMIN, LWMIN, + $ NSPLIT + DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, + $ TMP1, TNRM, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANST + EXTERNAL LSAME, ILAENV, DLAMCH, DLANST +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTEMR, DSTEIN, DSTERF, + $ DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* +* Test the input parameters. +* + IEEEOK = ILAENV( 10, 'DSTEVR', 'N', 1, 2, 3, 4 ) +* + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) +* + LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) ) + LWMIN = MAX( 1, 20*N ) + LIWMIN = MAX( 1, 10*N ) +* +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -7 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -9 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -14 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -17 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -19 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSTEVR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = D( 1 ) + ELSE + IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN + M = 1 + W( 1 ) = D( 1 ) + END IF + END IF + 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 = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + IF( VALEIG ) THEN + VLL = VL + VUU = VU + END IF +* + TNRM = DLANST( 'M', N, D, E ) + IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / TNRM + ELSE IF( TNRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / TNRM + END IF + IF( ISCALE.EQ.1 ) THEN + CALL DSCAL( N, SIGMA, D, 1 ) + CALL DSCAL( N-1, SIGMA, E( 1 ), 1 ) + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF + +* Initialize indices into workspaces. Note: These indices are used only +* if DSTERF or DSTEMR fail. + +* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and +* stores the block indices of each of the M<=N eigenvalues. + INDIBL = 1 +* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and +* stores the starting and finishing indices of each block. + INDISP = INDIBL + N +* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors +* that corresponding to eigenvectors that fail to converge in +* DSTEIN. This information is discarded; if any fail, the driver +* returns INFO > 0. + INDIFL = INDISP + N +* INDIWO is the offset of the remaining integer workspace. + INDIWO = INDISP + N +* +* If all eigenvalues are desired, then +* call DSTERF or DSTEMR. If this fails for some eigenvalue, then +* try DSTEBZ. +* +* + TEST = .FALSE. + IF( INDEIG ) THEN + IF( IL.EQ.1 .AND. IU.EQ.N ) THEN + TEST = .TRUE. + END IF + END IF + IF( ( ALLEIG .OR. TEST ) .AND. IEEEOK.EQ.1 ) THEN + CALL DCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 ) + IF( .NOT.WANTZ ) THEN + CALL DCOPY( N, D, 1, W, 1 ) + CALL DSTERF( N, W, WORK, INFO ) + ELSE + CALL DCOPY( N, D, 1, WORK( N+1 ), 1 ) + IF (ABSTOL .LE. TWO*N*EPS) THEN + TRYRAC = .TRUE. + ELSE + TRYRAC = .FALSE. + END IF + CALL DSTEMR( JOBZ, 'A', N, WORK( N+1 ), WORK, VL, VU, IL, + $ IU, M, W, Z, LDZ, N, ISUPPZ, TRYRAC, + $ WORK( 2*N+1 ), LWORK-2*N, IWORK, LIWORK, INFO ) +* + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 10 + END IF + INFO = 0 + END IF +* +* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M, + $ NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ), WORK, + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL DSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ), + $ Z, LDZ, WORK, IWORK( INDIWO ), IWORK( INDIFL ), + $ INFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 10 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 30 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 20 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 20 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( I ) + W( I ) = W( J ) + IWORK( I ) = IWORK( J ) + W( J ) = TMP1 + IWORK( J ) = ITMP1 + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + END IF + 30 CONTINUE + END IF +* +* Causes problems with tests 19 & 20: +* IF (wantz .and. INDEIG ) Z( 1,1) = Z(1,1) / 1.002 + .002 +* +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN + RETURN +* +* End of DSTEVR +* + END diff --git a/math/lapack/src/main/fortran/dstevx.f b/math/lapack/src/main/fortran/dstevx.f new file mode 100644 index 0000000000..7acbdaa632 --- /dev/null +++ b/math/lapack/src/main/fortran/dstevx.f @@ -0,0 +1,464 @@ +*> \brief DSTEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSTEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, +* M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE +* INTEGER IL, INFO, IU, LDZ, M, N +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSTEVX computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric tridiagonal matrix A. Eigenvalues and +*> eigenvectors can be selected by specifying either a range of values +*> or a range of indices for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the n diagonal elements of the tridiagonal matrix +*> A. +*> On exit, D may be multiplied by a constant factor chosen +*> to avoid over/underflow in computing the eigenvalues. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (max(1,N-1)) +*> On entry, the (n-1) subdiagonal elements of the tridiagonal +*> matrix A in elements 1 to N-1 of E. +*> On exit, E may be multiplied by a constant factor chosen +*> to avoid over/underflow in computing the eigenvalues. +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less +*> than or equal to zero, then EPS*|T| will be used in +*> its place, where |T| is the 1-norm of the tridiagonal +*> matrix. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*DLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*DLAMCH('S'). +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first M elements contain the selected eigenvalues in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If an eigenvector fails to converge (INFO > 0), then that +*> column of Z contains the latest approximation to the +*> eigenvector, and the index of the eigenvector is returned +*> in IFAIL. If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (N) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvectors that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, then i eigenvectors failed to converge. +*> Their indices are stored in array IFAIL. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHEReigen +* +* ===================================================================== + SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, + $ M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE + INTEGER IL, INFO, IU, LDZ, M, N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ + CHARACTER ORDER + INTEGER I, IMAX, INDIBL, INDISP, INDIWO, INDWRK, + $ ISCALE, ITMP1, J, JJ, NSPLIT + DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, + $ TMP1, TNRM, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANST + EXTERNAL LSAME, DLAMCH, DLANST +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTEIN, DSTEQR, DSTERF, + $ DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -7 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -9 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) + $ INFO = -14 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSTEVX', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = D( 1 ) + ELSE + IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN + M = 1 + W( 1 ) = D( 1 ) + END IF + END IF + 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 = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + IF( VALEIG ) THEN + VLL = VL + VUU = VU + ELSE + VLL = ZERO + VUU = ZERO + END IF + TNRM = DLANST( 'M', N, D, E ) + IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / TNRM + ELSE IF( TNRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / TNRM + END IF + IF( ISCALE.EQ.1 ) THEN + CALL DSCAL( N, SIGMA, D, 1 ) + CALL DSCAL( N-1, SIGMA, E( 1 ), 1 ) + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF +* +* If all eigenvalues are desired and ABSTOL is less than zero, then +* call DSTERF or SSTEQR. If this fails for some eigenvalue, then +* try DSTEBZ. +* + TEST = .FALSE. + IF( INDEIG ) THEN + IF( IL.EQ.1 .AND. IU.EQ.N ) THEN + TEST = .TRUE. + END IF + END IF + IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN + CALL DCOPY( N, D, 1, W, 1 ) + CALL DCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 ) + INDWRK = N + 1 + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK, INFO ) + ELSE + CALL DSTEQR( 'I', N, W, WORK, Z, LDZ, WORK( INDWRK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 10 I = 1, N + IFAIL( I ) = 0 + 10 CONTINUE + END IF + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 20 + END IF + INFO = 0 + END IF +* +* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDWRK = 1 + INDIBL = 1 + INDISP = INDIBL + N + INDIWO = INDISP + N + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M, + $ NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ), + $ WORK( INDWRK ), IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL DSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ), + $ Z, LDZ, WORK( INDWRK ), IWORK( INDIWO ), IFAIL, + $ INFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 20 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 40 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 30 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 30 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 40 CONTINUE + END IF +* + RETURN +* +* End of DSTEVX +* + END diff --git a/math/lapack/src/main/fortran/dsycon.f b/math/lapack/src/main/fortran/dsycon.f new file mode 100644 index 0000000000..66e453659c --- /dev/null +++ b/math/lapack/src/main/fortran/dsycon.f @@ -0,0 +1,244 @@ +*> \brief \b DSYCON +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, +* IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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))). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by DSYTRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is DOUBLE PRECISION +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, + $ IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, KASE + DOUBLE PRECISION AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DSYTRS, 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**T) or inv(U*D*U**T). +* + 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/math/lapack/src/main/fortran/dsycon_3.f b/math/lapack/src/main/fortran/dsycon_3.f new file mode 100644 index 0000000000..0c3f696ff7 --- /dev/null +++ b/math/lapack/src/main/fortran/dsycon_3.f @@ -0,0 +1,285 @@ +*> \brief \b DSYCON_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYCON_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), E ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DSYCON_3 estimates the reciprocal of the condition number (in the +*> 1-norm) of a real symmetric matrix A using the factorization +*> computed by DSYTRF_RK or DSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> This routine uses BLAS3 solver DSYTRS_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix: +*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T); +*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by DSYTRF_RK and DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF_RK or DSYTRF_BK. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is DOUBLE PRECISION +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, + $ WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, KASE + DOUBLE PRECISION AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DSYTRS_3, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYCON_3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.LE.ZERO ) THEN + RETURN + END IF +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO I = N, 1, -1 + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO I = 1, N + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + END DO + END IF +* +* Estimate the 1-norm of the inverse. +* + KASE = 0 + 30 CONTINUE + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN +* +* Multiply by inv(L*D*L**T) or inv(U*D*U**T). +* + CALL DSYTRS_3( UPLO, N, 1, A, LDA, E, IPIV, WORK, N, INFO ) + GO TO 30 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + RETURN +* +* End of DSYCON_3 +* + END diff --git a/math/lapack/src/main/fortran/dsycon_rook.f b/math/lapack/src/main/fortran/dsycon_rook.f new file mode 100644 index 0000000000..4022adf7e5 --- /dev/null +++ b/math/lapack/src/main/fortran/dsycon_rook.f @@ -0,0 +1,258 @@ +*> \brief DSYCON_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYCON_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYCON_ROOK 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_ROOK. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by DSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is DOUBLE PRECISION +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> April 2012, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, + $ IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, KASE + DOUBLE PRECISION AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DSYTRS_ROOK, 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_ROOK', -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**T) or inv(U*D*U**T). +* + CALL DSYTRS_ROOK( 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_ROOK +* + END diff --git a/math/lapack/src/main/fortran/dsyconv.f b/math/lapack/src/main/fortran/dsyconv.f new file mode 100644 index 0000000000..f582bce651 --- /dev/null +++ b/math/lapack/src/main/fortran/dsyconv.f @@ -0,0 +1,366 @@ +*> \brief \b DSYCONV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYCONV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, WAY +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYCONV convert A given by TRF into L and D and vice-versa. +*> Get Non-diag elements of D (returned in workspace) and +*> apply or reverse permutation done in TRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] WAY +*> \verbatim +*> WAY is CHARACTER*1 +*> = 'C': Convert +*> = 'R': Revert +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by DSYTRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF. +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> E stores the supdiagonal/subdiagonal of the symmetric 1-by-1 +*> or 2-by-2 block diagonal matrix D in LDLT. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO, WAY + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Local Scalars .. + LOGICAL UPPER, CONVERT + INTEGER I, IP, J + DOUBLE PRECISION TEMP +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + CONVERT = LSAME( WAY, 'C' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYCONV', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* A is UPPER +* +* Convert A (A is upper) +* +* Convert VALUE +* + IF ( CONVERT ) THEN + I=N + E(1)=ZERO + DO WHILE ( I .GT. 1 ) + IF( IPIV(I) .LT. 0 ) THEN + E(I)=A(I-1,I) + E(I-1)=ZERO + A(I-1,I)=ZERO + I=I-1 + ELSE + E(I)=ZERO + ENDIF + I=I-1 + END DO +* +* Convert PERMUTATIONS +* + I=N + DO WHILE ( I .GE. 1 ) + IF( IPIV(I) .GT. 0) THEN + IP=IPIV(I) + IF( I .LT. N) THEN + DO 12 J= I+1,N + TEMP=A(IP,J) + A(IP,J)=A(I,J) + A(I,J)=TEMP + 12 CONTINUE + ENDIF + ELSE + IP=-IPIV(I) + IF( I .LT. N) THEN + DO 13 J= I+1,N + TEMP=A(IP,J) + A(IP,J)=A(I-1,J) + A(I-1,J)=TEMP + 13 CONTINUE + ENDIF + I=I-1 + ENDIF + I=I-1 + END DO + + ELSE +* +* Revert A (A is upper) +* +* +* Revert PERMUTATIONS +* + I=1 + DO WHILE ( I .LE. N ) + IF( IPIV(I) .GT. 0 ) THEN + IP=IPIV(I) + IF( I .LT. N) THEN + DO J= I+1,N + TEMP=A(IP,J) + A(IP,J)=A(I,J) + A(I,J)=TEMP + END DO + ENDIF + ELSE + IP=-IPIV(I) + I=I+1 + IF( I .LT. N) THEN + DO J= I+1,N + TEMP=A(IP,J) + A(IP,J)=A(I-1,J) + A(I-1,J)=TEMP + END DO + ENDIF + ENDIF + I=I+1 + END DO +* +* Revert VALUE +* + I=N + DO WHILE ( I .GT. 1 ) + IF( IPIV(I) .LT. 0 ) THEN + A(I-1,I)=E(I) + I=I-1 + ENDIF + I=I-1 + END DO + END IF + ELSE +* +* A is LOWER +* + IF ( CONVERT ) THEN +* +* Convert A (A is lower) +* +* +* Convert VALUE +* + I=1 + E(N)=ZERO + DO WHILE ( I .LE. N ) + IF( I.LT.N .AND. IPIV(I) .LT. 0 ) THEN + E(I)=A(I+1,I) + E(I+1)=ZERO + A(I+1,I)=ZERO + I=I+1 + ELSE + E(I)=ZERO + ENDIF + I=I+1 + END DO +* +* Convert PERMUTATIONS +* + I=1 + DO WHILE ( I .LE. N ) + IF( IPIV(I) .GT. 0 ) THEN + IP=IPIV(I) + IF (I .GT. 1) THEN + DO 22 J= 1,I-1 + TEMP=A(IP,J) + A(IP,J)=A(I,J) + A(I,J)=TEMP + 22 CONTINUE + ENDIF + ELSE + IP=-IPIV(I) + IF (I .GT. 1) THEN + DO 23 J= 1,I-1 + TEMP=A(IP,J) + A(IP,J)=A(I+1,J) + A(I+1,J)=TEMP + 23 CONTINUE + ENDIF + I=I+1 + ENDIF + I=I+1 + END DO + ELSE +* +* Revert A (A is lower) +* +* +* Revert PERMUTATIONS +* + I=N + DO WHILE ( I .GE. 1 ) + IF( IPIV(I) .GT. 0 ) THEN + IP=IPIV(I) + IF (I .GT. 1) THEN + DO J= 1,I-1 + TEMP=A(I,J) + A(I,J)=A(IP,J) + A(IP,J)=TEMP + END DO + ENDIF + ELSE + IP=-IPIV(I) + I=I-1 + IF (I .GT. 1) THEN + DO J= 1,I-1 + TEMP=A(I+1,J) + A(I+1,J)=A(IP,J) + A(IP,J)=TEMP + END DO + ENDIF + ENDIF + I=I-1 + END DO +* +* Revert VALUE +* + I=1 + DO WHILE ( I .LE. N-1 ) + IF( IPIV(I) .LT. 0 ) THEN + A(I+1,I)=E(I) + I=I+1 + ENDIF + I=I+1 + END DO + END IF + END IF + + RETURN +* +* End of DSYCONV +* + END diff --git a/math/lapack/src/main/fortran/dsyconvf.f b/math/lapack/src/main/fortran/dsyconvf.f new file mode 100644 index 0000000000..7672acfadf --- /dev/null +++ b/math/lapack/src/main/fortran/dsyconvf.f @@ -0,0 +1,559 @@ +*> \brief \b DSYCONVF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYCONVF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYCONVF( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, WAY +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> If parameter WAY = 'C': +*> DSYCONVF converts the factorization output format used in +*> DSYTRF provided on entry in parameter A into the factorization +*> output format used in DSYTRF_RK (or DSYTRF_BK) that is stored +*> on exit in parameters A and E. It also coverts in place details of +*> the intechanges stored in IPIV from the format used in DSYTRF into +*> the format used in DSYTRF_RK (or DSYTRF_BK). +*> +*> If parameter WAY = 'R': +*> DSYCONVF performs the conversion in reverse direction, i.e. +*> converts the factorization output format used in DSYTRF_RK +*> (or DSYTRF_BK) provided on entry in parametes A and E into +*> the factorization output format used in DSYTRF that is stored +*> on exit in parameter A. It also coverts in place details of +*> the intechanges stored in IPIV from the format used in DSYTRF_RK +*> (or DSYTRF_BK) into the format used in DSYTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix A. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] WAY +*> \verbatim +*> WAY is CHARACTER*1 +*> = 'C': Convert +*> = 'R': Revert +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> +*> 1) If WAY ='C': +*> +*> On entry, contains factorization details in format used in +*> DSYTRF: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> DSYTRF_RK or DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains factorization details in format used in +*> DSYTRF_RK or DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> DSYTRF: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> +*> 1) If WAY ='C': +*> +*> On entry, just a workspace. +*> +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> On exit, is not changed +*> \endverbatim +*. +*> \param[in,out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> +*> 1) If WAY ='C': +*> On entry, details of the interchanges and the block +*> structure of D in the format used in DSYTRF. +*> On exit, details of the interchanges and the block +*> structure of D in the format used in DSYTRF_RK +*> ( or DSYTRF_BK). +*> +*> 1) If WAY ='R': +*> On entry, details of the interchanges and the block +*> structure of D in the format used in DSYTRF_RK +*> ( or DSYTRF_BK). +*> On exit, details of the interchanges and the block +*> structure of D in the format used in DSYTRF. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* ===================================================================== + SUBROUTINE DSYCONVF( UPLO, WAY, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO, WAY + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* +* .. External Subroutines .. + EXTERNAL DSWAP, XERBLA +* .. Local Scalars .. + LOGICAL UPPER, CONVERT + INTEGER I, IP +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + CONVERT = LSAME( WAY, 'C' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYCONVF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin A is UPPER +* + IF ( CONVERT ) THEN +* +* Convert A (A is upper) +* +* +* Convert VALUE +* +* Assign superdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = N + E( 1 ) = ZERO + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + E( I ) = A( I-1, I ) + E( I-1 ) = ZERO + A( I-1, I ) = ZERO + I = I - 1 + ELSE + E( I ) = ZERO + END IF + I = I - 1 + END DO +* +* Convert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of upper part of A +* in factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( N-I, A( I, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N) +* + IP = -IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.(I-1) ) THEN + CALL DSWAP( N-I, A( I-1, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is no interchnge of rows i and and IPIV(i), +* so this should be reflected in IPIV format for +* *SYTRF_RK ( or *SYTRF_BK) +* + IPIV( I ) = I +* + I = I - 1 +* + END IF + I = I - 1 + END DO +* + ELSE +* +* Revert A (A is upper) +* +* +* Revert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of upper part of A +* in reverse factorization order where i increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N) +* + I = I + 1 + IP = -IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.(I-1) ) THEN + CALL DSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I-1, I+1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is one interchange of rows i-1 and IPIV(i-1), +* so this should be recorded in two consecutive entries +* in IPIV format for *SYTRF +* + IPIV( I ) = IPIV( I-1 ) +* + END IF + I = I + 1 + END DO +* +* Revert VALUE +* Assign superdiagonal entries of D from array E to +* superdiagonal entries of A. +* + I = N + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I-1, I ) = E( I ) + I = I - 1 + END IF + I = I - 1 + END DO +* +* End A is UPPER +* + END IF +* + ELSE +* +* Begin A is LOWER +* + IF ( CONVERT ) THEN +* +* Convert A (A is lower) +* +* +* Convert VALUE +* Assign subdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = 1 + E( N ) = ZERO + DO WHILE ( I.LE.N ) + IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN + E( I ) = A( I+1, I ) + E( I+1 ) = ZERO + A( I+1, I ) = ZERO + I = I + 1 + ELSE + E( I ) = ZERO + END IF + I = I + 1 + END DO +* +* Convert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of lower part of A +* in factorization order where k increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( I-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1) +* + IP = -IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.(I+1) ) THEN + CALL DSWAP( I-1, A( I+1, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is no interchnge of rows i and and IPIV(i), +* so this should be reflected in IPIV format for +* *SYTRF_RK ( or *SYTRF_BK) +* + IPIV( I ) = I +* + I = I + 1 +* + END IF + I = I + 1 + END DO +* + ELSE +* +* Revert A (A is lower) +* +* +* Revert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of lower part of A +* in reverse factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( I-1, A( IP, 1 ), LDA, + $ A( I, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1) +* + I = I - 1 + IP = -IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.(I+1) ) THEN + CALL DSWAP( I-1, A( IP, 1 ), LDA, + $ A( I+1, 1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is one interchange of rows i+1 and IPIV(i+1), +* so this should be recorded in consecutive entries +* in IPIV format for *SYTRF +* + IPIV( I ) = IPIV( I+1 ) +* + END IF + I = I - 1 + END DO +* +* Revert VALUE +* Assign subdiagonal entries of D from array E to +* subgiagonal entries of A. +* + I = 1 + DO WHILE ( I.LE.N-1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I + 1, I ) = E( I ) + I = I + 1 + END IF + I = I + 1 + END DO +* + END IF +* +* End A is LOWER +* + END IF + + RETURN +* +* End of DSYCONVF +* + END diff --git a/math/lapack/src/main/fortran/dsyconvf_rook.f b/math/lapack/src/main/fortran/dsyconvf_rook.f new file mode 100644 index 0000000000..541a342d20 --- /dev/null +++ b/math/lapack/src/main/fortran/dsyconvf_rook.f @@ -0,0 +1,544 @@ +*> \brief \b DSYCONVF_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYCONVF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYCONVF_ROOK( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, WAY +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> If parameter WAY = 'C': +*> DSYCONVF_ROOK converts the factorization output format used in +*> DSYTRF_ROOK provided on entry in parameter A into the factorization +*> output format used in DSYTRF_RK (or DSYTRF_BK) that is stored +*> on exit in parameters A and E. IPIV format for DSYTRF_ROOK and +*> DSYTRF_RK (or DSYTRF_BK) is the same and is not converted. +*> +*> If parameter WAY = 'R': +*> DSYCONVF_ROOK performs the conversion in reverse direction, i.e. +*> converts the factorization output format used in DSYTRF_RK +*> (or DSYTRF_BK) provided on entry in parametes A and E into +*> the factorization output format used in DSYTRF_ROOK that is stored +*> on exit in parameter A. IPIV format for DSYTRF_ROOK and +*> DSYTRF_RK (or DSYTRF_BK) is the same and is not converted. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix A. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] WAY +*> \verbatim +*> WAY is CHARACTER*1 +*> = 'C': Convert +*> = 'R': Revert +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> +*> 1) If WAY ='C': +*> +*> On entry, contains factorization details in format used in +*> DSYTRF_ROOK: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> DSYTRF_RK or DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains factorization details in format used in +*> DSYTRF_RK or DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> DSYTRF_ROOK: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> +*> 1) If WAY ='C': +*> +*> On entry, just a workspace. +*> +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> On exit, is not changed +*> \endverbatim +*. +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On entry, details of the interchanges and the block +*> structure of D as determined: +*> 1) by DSYTRF_ROOK, if WAY ='C'; +*> 2) by DSYTRF_RK (or DSYTRF_BK), if WAY ='R'. +*> The IPIV format is the same for all these routines. +*> +*> On exit, is not changed. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* ===================================================================== + SUBROUTINE DSYCONVF_ROOK( UPLO, WAY, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO, WAY + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* +* .. External Subroutines .. + EXTERNAL DSWAP, XERBLA +* .. Local Scalars .. + LOGICAL UPPER, CONVERT + INTEGER I, IP, IP2 +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + CONVERT = LSAME( WAY, 'C' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYCONVF_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin A is UPPER +* + IF ( CONVERT ) THEN +* +* Convert A (A is upper) +* +* +* Convert VALUE +* +* Assign superdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = N + E( 1 ) = ZERO + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + E( I ) = A( I-1, I ) + E( I-1 ) = ZERO + A( I-1, I ) = ZERO + I = I - 1 + ELSE + E( I ) = ZERO + END IF + I = I - 1 + END DO +* +* Convert PERMUTATIONS +* +* Apply permutaions to submatrices of upper part of A +* in factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( N-I, A( I, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i and IPIV(i) and i-1 and IPIV(i-1) +* in A(1:i,N-i:N) +* + IP = -IPIV( I ) + IP2 = -IPIV( I-1 ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( N-I, A( I, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + IF( IP2.NE.(I-1) ) THEN + CALL DSWAP( N-I, A( I-1, I+1 ), LDA, + $ A( IP2, I+1 ), LDA ) + END IF + END IF + I = I - 1 +* + END IF + I = I - 1 + END DO +* + ELSE +* +* Revert A (A is upper) +* +* +* Revert PERMUTATIONS +* +* Apply permutaions to submatrices of upper part of A +* in reverse factorization order where i increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i-1 and IPIV(i-1) and i and IPIV(i) +* in A(1:i,N-i:N) +* + I = I + 1 + IP = -IPIV( I ) + IP2 = -IPIV( I-1 ) + IF( I.LT.N ) THEN + IF( IP2.NE.(I-1) ) THEN + CALL DSWAP( N-I, A( IP2, I+1 ), LDA, + $ A( I-1, I+1 ), LDA ) + END IF + IF( IP.NE.I ) THEN + CALL DSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I, I+1 ), LDA ) + END IF + END IF +* + END IF + I = I + 1 + END DO +* +* Revert VALUE +* Assign superdiagonal entries of D from array E to +* superdiagonal entries of A. +* + I = N + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I-1, I ) = E( I ) + I = I - 1 + END IF + I = I - 1 + END DO +* +* End A is UPPER +* + END IF +* + ELSE +* +* Begin A is LOWER +* + IF ( CONVERT ) THEN +* +* Convert A (A is lower) +* +* +* Convert VALUE +* Assign subdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = 1 + E( N ) = ZERO + DO WHILE ( I.LE.N ) + IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN + E( I ) = A( I+1, I ) + E( I+1 ) = ZERO + A( I+1, I ) = ZERO + I = I + 1 + ELSE + E( I ) = ZERO + END IF + I = I + 1 + END DO +* +* Convert PERMUTATIONS +* +* Apply permutaions to submatrices of lower part of A +* in factorization order where i increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( I-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i and IPIV(i) and i+1 and IPIV(i+1) +* in A(i:N,1:i-1) +* + IP = -IPIV( I ) + IP2 = -IPIV( I+1 ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( I-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + IF( IP2.NE.(I+1) ) THEN + CALL DSWAP( I-1, A( I+1, 1 ), LDA, + $ A( IP2, 1 ), LDA ) + END IF + END IF + I = I + 1 +* + END IF + I = I + 1 + END DO +* + ELSE +* +* Revert A (A is lower) +* +* +* Revert PERMUTATIONS +* +* Apply permutaions to submatrices of lower part of A +* in reverse factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( I-1, A( IP, 1 ), LDA, + $ A( I, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i+1 and IPIV(i+1) and i and IPIV(i) +* in A(i:N,1:i-1) +* + I = I - 1 + IP = -IPIV( I ) + IP2 = -IPIV( I+1 ) + IF ( I.GT.1 ) THEN + IF( IP2.NE.(I+1) ) THEN + CALL DSWAP( I-1, A( IP2, 1 ), LDA, + $ A( I+1, 1 ), LDA ) + END IF + IF( IP.NE.I ) THEN + CALL DSWAP( I-1, A( IP, 1 ), LDA, + $ A( I, 1 ), LDA ) + END IF + END IF +* + END IF + I = I - 1 + END DO +* +* Revert VALUE +* Assign subdiagonal entries of D from array E to +* subgiagonal entries of A. +* + I = 1 + DO WHILE ( I.LE.N-1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I + 1, I ) = E( I ) + I = I + 1 + END IF + I = I + 1 + END DO +* + END IF +* +* End A is LOWER +* + END IF + + RETURN +* +* End of DSYCONVF_ROOK +* + END diff --git a/math/lapack/src/main/fortran/dsyequb.f b/math/lapack/src/main/fortran/dsyequb.f new file mode 100644 index 0000000000..dd1dc80bb5 --- /dev/null +++ b/math/lapack/src/main/fortran/dsyequb.f @@ -0,0 +1,334 @@ +*> \brief \b DSYEQUB +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, N +* DOUBLE PRECISION AMAX, SCOND +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), S( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYEQUB computes row and column scalings intended to equilibrate a +*> symmetric matrix A (with respect to the Euclidean norm) and reduce +*> its condition number. The scale factors S are computed by the BIN +*> algorithm (see references) so that the scaled matrix B with elements +*> B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of +*> the smallest possible condition number over all possible diagonal +*> scalings. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The N-by-N symmetric matrix whose scaling factors are to be +*> computed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, S contains the scale factors for A. +*> \endverbatim +*> +*> \param[out] SCOND +*> \verbatim +*> SCOND is DOUBLE PRECISION +*> If INFO = 0, S contains the ratio of the smallest S(i) to +*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too +*> large nor too small, it is not worth scaling by S. +*> \endverbatim +*> +*> \param[out] AMAX +*> \verbatim +*> AMAX is DOUBLE PRECISION +*> Largest absolute value of any matrix element. If AMAX is +*> very close to overflow or very close to underflow, the +*> matrix should be scaled. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the i-th diagonal element is nonpositive. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par References: +* ================ +*> +*> Livne, O.E. and Golub, G.H., "Scaling by Binormalization", \n +*> Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. \n +*> DOI 10.1023/B:NUMA.0000016606.32820.69 \n +*> Tech report version: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.3.1679 +*> +* ===================================================================== + SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, N + DOUBLE PRECISION AMAX, SCOND + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), S( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) + INTEGER MAX_ITER + PARAMETER ( MAX_ITER = 100 ) +* .. +* .. Local Scalars .. + INTEGER I, J, ITER + DOUBLE PRECISION AVG, STD, TOL, C0, C1, C2, T, U, SI, D, BASE, + $ SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ + LOGICAL UP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME + EXTERNAL DLAMCH, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT. ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -1 + ELSE IF ( N .LT. 0 ) THEN + INFO = -2 + ELSE IF ( LDA .LT. MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'DSYEQUB', -INFO ) + RETURN + END IF + + UP = LSAME( UPLO, 'U' ) + AMAX = ZERO +* +* Quick return if possible. +* + IF ( N .EQ. 0 ) THEN + SCOND = ONE + RETURN + END IF + + DO I = 1, N + S( I ) = ZERO + END DO + + AMAX = ZERO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + S( I ) = MAX( S( I ), ABS( A( I, J ) ) ) + S( J ) = MAX( S( J ), ABS( A( I, J ) ) ) + AMAX = MAX( AMAX, ABS( A( I, J ) ) ) + END DO + S( J ) = MAX( S( J ), ABS( A( J, J ) ) ) + AMAX = MAX( AMAX, ABS( A( J, J ) ) ) + END DO + ELSE + DO J = 1, N + S( J ) = MAX( S( J ), ABS( A( J, J ) ) ) + AMAX = MAX( AMAX, ABS( A( J, J ) ) ) + DO I = J+1, N + S( I ) = MAX( S( I ), ABS( A( I, J ) ) ) + S( J ) = MAX( S( J ), ABS( A( I, J ) ) ) + AMAX = MAX( AMAX, ABS( A( I, J ) ) ) + END DO + END DO + END IF + DO J = 1, N + S( J ) = 1.0D0 / S( J ) + END DO + + TOL = ONE / SQRT( 2.0D0 * N ) + + DO ITER = 1, MAX_ITER + SCALE = 0.0D0 + SUMSQ = 0.0D0 +* beta = |A|s + DO I = 1, N + WORK( I ) = ZERO + END DO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I ) + END DO + WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J ) + END DO + ELSE + DO J = 1, N + WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J ) + DO I = J+1, N + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I ) + END DO + END DO + END IF + +* avg = s^T beta / n + AVG = 0.0D0 + DO I = 1, N + AVG = AVG + S( I )*WORK( I ) + END DO + AVG = AVG / N + + STD = 0.0D0 + DO I = N+1, 2*N + WORK( I ) = S( I-N ) * WORK( I-N ) - AVG + END DO + CALL DLASSQ( N, WORK( N+1 ), 1, SCALE, SUMSQ ) + STD = SCALE * SQRT( SUMSQ / N ) + + IF ( STD .LT. TOL * AVG ) GOTO 999 + + DO I = 1, N + T = ABS( A( I, I ) ) + SI = S( I ) + C2 = ( N-1 ) * T + C1 = ( N-2 ) * ( WORK( I ) - T*SI ) + C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG + D = C1*C1 - 4*C0*C2 + + IF ( D .LE. 0 ) THEN + INFO = -1 + RETURN + END IF + SI = -2*C0 / ( C1 + SQRT( D ) ) + + D = SI - S( I ) + U = ZERO + IF ( UP ) THEN + DO J = 1, I + T = ABS( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = ABS( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + ELSE + DO J = 1, I + T = ABS( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = ABS( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + END IF + + AVG = AVG + ( U + WORK( I ) ) * D / N + S( I ) = SI + END DO + END DO + + 999 CONTINUE + + SMLNUM = DLAMCH( 'SAFEMIN' ) + BIGNUM = ONE / SMLNUM + SMIN = BIGNUM + SMAX = ZERO + T = ONE / SQRT( AVG ) + BASE = DLAMCH( 'B' ) + U = ONE / LOG( BASE ) + DO I = 1, N + S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) + SMIN = MIN( SMIN, S( I ) ) + SMAX = MAX( SMAX, S( I ) ) + END DO + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) +* + END diff --git a/math/lapack/src/main/fortran/dsyev.f b/math/lapack/src/main/fortran/dsyev.f new file mode 100644 index 0000000000..ee8c479abe --- /dev/null +++ b/math/lapack/src/main/fortran/dsyev.f @@ -0,0 +1,286 @@ +*> \brief DSYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYEV computes all eigenvalues and, optionally, eigenvectors of a +*> real symmetric matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYeigen +* +* ===================================================================== + SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dsyev_2stage.f b/math/lapack/src/main/fortran/dsyev_2stage.f new file mode 100644 index 0000000000..af622fa2ea --- /dev/null +++ b/math/lapack/src/main/fortran/dsyev_2stage.f @@ -0,0 +1,348 @@ +*> \brief DSYEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYEV_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, +* INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYEV_2STAGE computes all eigenvalues and, optionally, eigenvectors of a +*> real symmetric matrix A using the 2stage technique for +*> the reduction to tridiagonal. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension LWORK +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + 2*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + 2*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, + $ INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS + 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, + $ XERBLA, DSYTRD_2STAGE +* .. +* .. 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.( 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 + KD = ILAENV( 17, 'DSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'DSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = 2*N + LHTRD + LWTRD + WORK( 1 ) = LWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYEV_2STAGE ', -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_2STAGE to reduce symmetric matrix to tridiagonal form. +* + INDE = 1 + INDTAU = INDE + N + INDHOUS = INDTAU + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL DSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK( INDE ), + $ WORK( INDTAU ), WORK( INDHOUS ), LHTRD, + $ 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 +* Not available in this release, and agrument checking should not +* let it getting here + RETURN + 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 ) = LWMIN +* + RETURN +* +* End of DSYEV_2STAGE +* + END diff --git a/math/lapack/src/main/fortran/dsyevd.f b/math/lapack/src/main/fortran/dsyevd.f new file mode 100644 index 0000000000..2db67846dc --- /dev/null +++ b/math/lapack/src/main/fortran/dsyevd.f @@ -0,0 +1,357 @@ +*> \brief DSYEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, +* LIWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, LDA, LIWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYEVD computes all eigenvalues and, optionally, eigenvectors of a +*> real symmetric matrix A. If eigenvectors are desired, it uses a +*> divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> +*> Because of large use of BLAS of level 3, DSYEVD needs N**2 more +*> workspace than DSYEVX. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, +*> dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If N <= 1, LWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1. +*> If JOBZ = 'V' and N > 1, LWORK must be at least +*> 1 + 6*N + 2*N**2. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK and IWORK +*> arrays, returns these values as the first entries of the WORK +*> and IWORK arrays, and no error message related to LWORK or +*> LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If N <= 1, LIWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LIWORK must be at least 1. +*> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i and JOBZ = 'N', then the algorithm failed +*> to converge; i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> if INFO = i and JOBZ = 'V', then the algorithm failed +*> to compute an eigenvalue while working on the submatrix +*> lying in rows and columns INFO/(N+1) through +*> mod(INFO,N+1). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYeigen +* +*> \par Contributors: +* ================== +*> +*> Jeff Rutter, Computer Science Division, University of California +*> at Berkeley, USA \n +*> Modified by Francoise Tisseur, University of Tennessee \n +*> Modified description of INFO. Sven, 16 Feb 05. \n + + +*> +* ===================================================================== + SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, + $ LIWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LIWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. +* + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE, + $ LIOPT, LIWMIN, LLWORK, LLWRK2, LOPT, LWMIN + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DLASCL, DORMTR, DSCAL, DSTEDC, 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 .OR. LIWORK.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 + IF( N.LE.1 ) THEN + LIWMIN = 1 + LWMIN = 1 + LOPT = LWMIN + LIOPT = LIWMIN + ELSE + IF( WANTZ ) THEN + LIWMIN = 3 + 5*N + LWMIN = 1 + 6*N + 2*N**2 + ELSE + LIWMIN = 1 + LWMIN = 2*N + 1 + END IF + LOPT = MAX( LWMIN, 2*N + + $ ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) + LIOPT = LIWMIN + END IF + WORK( 1 ) = LOPT + IWORK( 1 ) = LIOPT +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -8 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYEVD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + W( 1 ) = A( 1, 1 ) + 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 + INDWK2 = INDWRK + N*N + LLWRK2 = LWORK - INDWK2 + 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 +* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the +* tridiagonal matrix, then call DORMTR to multiply it by the +* Householder transformations stored in A. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE + CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, + $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO ) + CALL DORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ), + $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO ) + CALL DLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( N, ONE / SIGMA, W, 1 ) +* + WORK( 1 ) = LOPT + IWORK( 1 ) = LIOPT +* + RETURN +* +* End of DSYEVD +* + END diff --git a/math/lapack/src/main/fortran/dsyevd_2stage.f b/math/lapack/src/main/fortran/dsyevd_2stage.f new file mode 100644 index 0000000000..d9d080cb1e --- /dev/null +++ b/math/lapack/src/main/fortran/dsyevd_2stage.f @@ -0,0 +1,406 @@ +*> \brief DSYEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYEVD_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYEVD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, +* IWORK, LIWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, LDA, LIWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYEVD_2STAGE computes all eigenvalues and, optionally, eigenvectors of a +*> real symmetric matrix A using the 2stage technique for +*> the reduction to tridiagonal. If eigenvectors are desired, it uses a +*> divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, +*> dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If N <= 1, LWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + 2*N+1 +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + 2*N+1 +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be at least +*> 1 + 6*N + 2*N**2. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK and IWORK +*> arrays, returns these values as the first entries of the WORK +*> and IWORK arrays, and no error message related to LWORK or +*> LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If N <= 1, LIWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LIWORK must be at least 1. +*> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i and JOBZ = 'N', then the algorithm failed +*> to converge; i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> if INFO = i and JOBZ = 'V', then the algorithm failed +*> to compute an eigenvalue while working on the submatrix +*> lying in rows and columns INFO/(N+1) through +*> mod(INFO,N+1). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYeigen +* +*> \par Contributors: +* ================== +*> +*> Jeff Rutter, Computer Science Division, University of California +*> at Berkeley, USA \n +*> Modified by Francoise Tisseur, University of Tennessee \n +*> Modified description of INFO. Sven, 16 Feb 05. \n +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYEVD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, + $ IWORK, LIWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LIWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. +* + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE, + $ LIWMIN, LLWORK, LLWRK2, LWMIN, + $ LHTRD, LWTRD, KD, IB, INDHOUS + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DLASCL, DORMTR, DSCAL, DSTEDC, DSTERF, + $ DSYTRD_2STAGE, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( 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 + IF( N.LE.1 ) THEN + LIWMIN = 1 + LWMIN = 1 + ELSE + KD = ILAENV( 17, 'DSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'DSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + IF( WANTZ ) THEN + LIWMIN = 3 + 5*N + LWMIN = 1 + 6*N + 2*N**2 + ELSE + LIWMIN = 1 + LWMIN = 2*N + 1 + LHTRD + LWTRD + END IF + END IF + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -8 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYEVD_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + W( 1 ) = A( 1, 1 ) + 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_2STAGE to reduce symmetric matrix to tridiagonal form. +* + INDE = 1 + INDTAU = INDE + N + INDHOUS = INDTAU + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 + INDWK2 = INDWRK + N*N + LLWRK2 = LWORK - INDWK2 + 1 +* + CALL DSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK( INDE ), + $ WORK( INDTAU ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, first call +* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the +* tridiagonal matrix, then call DORMTR to multiply it by the +* Householder transformations stored in A. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE +* Not available in this release, and agrument checking should not +* let it getting here + RETURN + CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, + $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO ) + CALL DORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ), + $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO ) + CALL DLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( N, ONE / SIGMA, W, 1 ) +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of DSYEVD_2STAGE +* + END diff --git a/math/lapack/src/main/fortran/dsyevr.f b/math/lapack/src/main/fortran/dsyevr.f new file mode 100644 index 0000000000..42f6081cf1 --- /dev/null +++ b/math/lapack/src/main/fortran/dsyevr.f @@ -0,0 +1,681 @@ +*> \brief DSYEVR computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYEVR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, +* ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, +* IWORK, LIWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER ISUPPZ( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYEVR computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric matrix A. Eigenvalues and eigenvectors can be +*> selected by specifying either a range of values or a range of +*> indices for the desired eigenvalues. +*> +*> DSYEVR first reduces the matrix A to tridiagonal form T with a call +*> to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute +*> the eigenspectrum using Relatively Robust Representations. DSTEMR +*> computes eigenvalues by the dqds algorithm, while orthogonal +*> eigenvectors are computed from various "good" L D L^T representations +*> (also known as Relatively Robust Representations). Gram-Schmidt +*> orthogonalization is avoided as far as possible. More specifically, +*> the various steps of the algorithm are as follows. +*> +*> For each unreduced block (submatrix) of T, +*> (a) Compute T - sigma I = L D L^T, so that L and D +*> define all the wanted eigenvalues to high relative accuracy. +*> This means that small relative changes in the entries of D and L +*> cause only small relative changes in the eigenvalues and +*> eigenvectors. The standard (unfactored) representation of the +*> tridiagonal matrix T does not have this property in general. +*> (b) Compute the eigenvalues to suitable accuracy. +*> If the eigenvectors are desired, the algorithm attains full +*> accuracy of the computed eigenvalues only right before +*> the corresponding vectors have to be computed, see steps c) and d). +*> (c) For each cluster of close eigenvalues, select a new +*> shift close to the cluster, find a new factorization, and refine +*> the shifted eigenvalues to suitable accuracy. +*> (d) For each eigenvalue with a large enough relative separation compute +*> the corresponding eigenvector by forming a rank revealing twisted +*> factorization. Go back to (c) for any clusters that remain. +*> +*> The desired accuracy of the output can be specified by the input +*> parameter ABSTOL. +*> +*> For more details, see DSTEMR's documentation and: +*> - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations +*> to compute orthogonal eigenvectors of symmetric tridiagonal matrices," +*> Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. +*> - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and +*> Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, +*> 2004. Also LAPACK Working Note 154. +*> - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric +*> tridiagonal eigenvalue/eigenvector problem", +*> Computer Science Division Technical Report No. UCB/CSD-97-971, +*> UC Berkeley, May 1997. +*> +*> +*> Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested +*> on machines which conform to the ieee-754 floating point standard. +*> DSYEVR calls DSTEBZ and SSTEIN on non-ieee machines and +*> when partial spectrum requests are made. +*> +*> Normal execution of DSTEMR may create NaNs and infinities and +*> hence may abort due to a floating point exception in environments +*> which do not handle NaNs and infinities in the ieee standard default +*> manner. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and +*> DSTEIN are called +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, the lower triangle (if UPLO='L') or the upper +*> triangle (if UPLO='U') of A, including the diagonal, is +*> destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing A to tridiagonal form. +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> +*> If high relative accuracy is important, set ABSTOL to +*> DLAMCH( 'Safe minimum' ). Doing so will guarantee that +*> eigenvalues are computed to high relative accuracy when +*> possible in future releases. The current code does not +*> make any guarantees about high relative accuracy, but +*> future releases will. See J. Barlow and J. Demmel, +*> "Computing Accurate Eigensystems of Scaled Diagonally +*> Dominant Matrices", LAPACK Working Note #7, for a discussion +*> of which matrices define their eigenvalues to high relative +*> accuracy. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first M elements contain the selected eigenvalues in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> Supplying N columns is always safe. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] ISUPPZ +*> \verbatim +*> ISUPPZ is INTEGER array, dimension ( 2*max(1,M) ) +*> The support of the eigenvectors in Z, i.e., the indices +*> indicating the nonzero elements in Z. The i-th eigenvector +*> is nonzero only in elements ISUPPZ( 2*i-1 ) through +*> ISUPPZ( 2*i ). This is an output of DSTEMR (tridiagonal +*> matrix). The support of the eigenvectors of A is typically +*> 1:N because of the orthogonal transformations applied by DORMTR. +*> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= max(1,26*N). +*> For optimal efficiency, LWORK >= (NB+6)*N, +*> where NB is the max of the blocksize for DSYTRD and DORMTR +*> returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. LIWORK >= max(1,10*N). +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal size of the IWORK array, +*> returns this value as the first entry of the IWORK array, and +*> no error message related to LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: Internal error +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleSYeigen +* +*> \par Contributors: +* ================== +*> +*> Inderjit Dhillon, IBM Almaden, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Ken Stanley, Computer Science Division, University of +*> California at Berkeley, USA \n +*> Jason Riedy, Computer Science Division, University of +*> California at Berkeley, USA \n +*> +* ===================================================================== + SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, + $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, + $ IWORK, LIWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER ISUPPZ( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ, + $ TRYRAC + CHARACTER ORDER + INTEGER I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE, + $ INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU, + $ INDWK, INDWKN, ISCALE, J, JJ, LIWMIN, + $ LLWORK, LLWRKN, LWKOPT, LWMIN, NB, NSPLIT + DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DORMTR, DSCAL, DSTEBZ, DSTEMR, DSTEIN, + $ DSTERF, DSWAP, DSYTRD, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + IEEEOK = ILAENV( 10, 'DSYEVR', 'N', 1, 2, 3, 4 ) +* + LOWER = LSAME( UPLO, 'L' ) + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) +* + LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) ) +* + LWMIN = MAX( 1, 26*N ) + LIWMIN = MAX( 1, 10*N ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -8 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -10 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -15 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -18 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -20 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) + NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) ) + LWKOPT = MAX( ( NB+1 )*N, LWMIN ) + WORK( 1 ) = LWKOPT + IWORK( 1 ) = LIWMIN + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYEVR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( N.EQ.1 ) THEN + WORK( 1 ) = 7 + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + ELSE + IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + END IF + END IF + IF( WANTZ ) THEN + Z( 1, 1 ) = ONE + ISUPPZ( 1 ) = 1 + ISUPPZ( 2 ) = 1 + END IF + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF (VALEIG) THEN + VLL = VL + VUU = VU + END IF + ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) + 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 + IF( LOWER ) THEN + DO 10 J = 1, N + CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL DSCAL( J, SIGMA, A( 1, J ), 1 ) + 20 CONTINUE + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF + +* Initialize indices into workspaces. Note: The IWORK indices are +* used only if DSTERF or DSTEMR fail. + +* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the +* elementary reflectors used in DSYTRD. + INDTAU = 1 +* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. + INDD = INDTAU + N +* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the +* tridiagonal matrix from DSYTRD. + INDE = INDD + N +* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over +* -written by DSTEMR (the DSTERF path copies the diagonal to W). + INDDD = INDE + N +* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over +* -written while computing the eigenvalues in DSTERF and DSTEMR. + INDEE = INDDD + N +* INDWK is the starting offset of the left-over workspace, and +* LLWORK is the remaining workspace size. + INDWK = INDEE + N + LLWORK = LWORK - INDWK + 1 + +* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and +* stores the block indices of each of the M<=N eigenvalues. + INDIBL = 1 +* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and +* stores the starting and finishing indices of each block. + INDISP = INDIBL + N +* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors +* that corresponding to eigenvectors that fail to converge in +* DSTEIN. This information is discarded; if any fail, the driver +* returns INFO > 0. + INDIFL = INDISP + N +* INDIWO is the offset of the remaining integer workspace. + INDIWO = INDIFL + N + +* +* Call DSYTRD to reduce symmetric matrix to tridiagonal form. +* + CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ), + $ WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO ) +* +* If all eigenvalues are desired +* then call DSTERF or DSTEMR and DORMTR. +* + IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. + $ IEEEOK.EQ.1 ) THEN + IF( .NOT.WANTZ ) THEN + CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTERF( N, W, WORK( INDEE ), INFO ) + ELSE + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 ) +* + IF (ABSTOL .LE. TWO*N*EPS) THEN + TRYRAC = .TRUE. + ELSE + TRYRAC = .FALSE. + END IF + CALL DSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ), + $ VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ, + $ TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK, + $ INFO ) +* +* +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by DSTEMR. +* + IF( WANTZ .AND. INFO.EQ.0 ) THEN + INDWKN = INDE + LLWRKN = LWORK - INDWKN + 1 + CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, + $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), + $ LLWRKN, IINFO ) + END IF + END IF +* +* + IF( INFO.EQ.0 ) THEN +* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are +* undefined. + M = N + GO TO 30 + END IF + INFO = 0 + END IF +* +* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. +* Also call DSTEBZ and DSTEIN if DSTEMR fails. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ WORK( INDWK ), IWORK( INDIWO ), IWORK( INDIFL ), + $ INFO ) +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by DSTEIN. +* + INDWKN = INDE + LLWRKN = LWORK - INDWKN + 1 + CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* +* Jump here if DSTEMR/DSTEIN succeeded. + 30 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. Note: We do not sort the IFAIL portion of IWORK. +* It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do +* not return this detailed information to the user. +* + IF( WANTZ ) THEN + DO 50 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 40 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 40 CONTINUE +* + IF( I.NE.0 ) THEN + W( I ) = W( J ) + W( J ) = TMP1 + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + END IF + 50 CONTINUE + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWKOPT + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of DSYEVR +* + END diff --git a/math/lapack/src/main/fortran/dsyevr_2stage.f b/math/lapack/src/main/fortran/dsyevr_2stage.f new file mode 100644 index 0000000000..ae62582367 --- /dev/null +++ b/math/lapack/src/main/fortran/dsyevr_2stage.f @@ -0,0 +1,740 @@ +*> \brief DSYEVR_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYEVR_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, +* IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, +* LWORK, IWORK, LIWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER ISUPPZ( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYEVR_2STAGE computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric matrix A using the 2stage technique for +*> the reduction to tridiagonal. Eigenvalues and eigenvectors can be +*> selected by specifying either a range of values or a range of +*> indices for the desired eigenvalues. +*> +*> DSYEVR_2STAGE first reduces the matrix A to tridiagonal form T with a call +*> to DSYTRD. Then, whenever possible, DSYEVR_2STAGE calls DSTEMR to compute +*> the eigenspectrum using Relatively Robust Representations. DSTEMR +*> computes eigenvalues by the dqds algorithm, while orthogonal +*> eigenvectors are computed from various "good" L D L^T representations +*> (also known as Relatively Robust Representations). Gram-Schmidt +*> orthogonalization is avoided as far as possible. More specifically, +*> the various steps of the algorithm are as follows. +*> +*> For each unreduced block (submatrix) of T, +*> (a) Compute T - sigma I = L D L^T, so that L and D +*> define all the wanted eigenvalues to high relative accuracy. +*> This means that small relative changes in the entries of D and L +*> cause only small relative changes in the eigenvalues and +*> eigenvectors. The standard (unfactored) representation of the +*> tridiagonal matrix T does not have this property in general. +*> (b) Compute the eigenvalues to suitable accuracy. +*> If the eigenvectors are desired, the algorithm attains full +*> accuracy of the computed eigenvalues only right before +*> the corresponding vectors have to be computed, see steps c) and d). +*> (c) For each cluster of close eigenvalues, select a new +*> shift close to the cluster, find a new factorization, and refine +*> the shifted eigenvalues to suitable accuracy. +*> (d) For each eigenvalue with a large enough relative separation compute +*> the corresponding eigenvector by forming a rank revealing twisted +*> factorization. Go back to (c) for any clusters that remain. +*> +*> The desired accuracy of the output can be specified by the input +*> parameter ABSTOL. +*> +*> For more details, see DSTEMR's documentation and: +*> - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations +*> to compute orthogonal eigenvectors of symmetric tridiagonal matrices," +*> Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. +*> - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and +*> Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, +*> 2004. Also LAPACK Working Note 154. +*> - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric +*> tridiagonal eigenvalue/eigenvector problem", +*> Computer Science Division Technical Report No. UCB/CSD-97-971, +*> UC Berkeley, May 1997. +*> +*> +*> Note 1 : DSYEVR_2STAGE calls DSTEMR when the full spectrum is requested +*> on machines which conform to the ieee-754 floating point standard. +*> DSYEVR_2STAGE calls DSTEBZ and SSTEIN on non-ieee machines and +*> when partial spectrum requests are made. +*> +*> Normal execution of DSTEMR may create NaNs and infinities and +*> hence may abort due to a floating point exception in environments +*> which do not handle NaNs and infinities in the ieee standard default +*> manner. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and +*> DSTEIN are called +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, the lower triangle (if UPLO='L') or the upper +*> triangle (if UPLO='U') of A, including the diagonal, is +*> destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing A to tridiagonal form. +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> +*> If high relative accuracy is important, set ABSTOL to +*> DLAMCH( 'Safe minimum' ). Doing so will guarantee that +*> eigenvalues are computed to high relative accuracy when +*> possible in future releases. The current code does not +*> make any guarantees about high relative accuracy, but +*> future releases will. See J. Barlow and J. Demmel, +*> "Computing Accurate Eigensystems of Scaled Diagonally +*> Dominant Matrices", LAPACK Working Note #7, for a discussion +*> of which matrices define their eigenvalues to high relative +*> accuracy. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first M elements contain the selected eigenvalues in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> Supplying N columns is always safe. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] ISUPPZ +*> \verbatim +*> ISUPPZ is INTEGER array, dimension ( 2*max(1,M) ) +*> The support of the eigenvectors in Z, i.e., the indices +*> indicating the nonzero elements in Z. The i-th eigenvector +*> is nonzero only in elements ISUPPZ( 2*i-1 ) through +*> ISUPPZ( 2*i ). This is an output of DSTEMR (tridiagonal +*> matrix). The support of the eigenvectors of A is typically +*> 1:N because of the orthogonal transformations applied by DORMTR. +*> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, 26*N, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + 5*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + 5*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. LIWORK >= max(1,10*N). +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal size of the IWORK array, +*> returns this value as the first entry of the IWORK array, and +*> no error message related to LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: Internal error +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleSYeigen +* +*> \par Contributors: +* ================== +*> +*> Inderjit Dhillon, IBM Almaden, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Ken Stanley, Computer Science Division, University of +*> California at Berkeley, USA \n +*> Jason Riedy, Computer Science Division, University of +*> California at Berkeley, USA \n +*> +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, + $ IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, + $ LWORK, IWORK, LIWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER ISUPPZ( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ, + $ TRYRAC + CHARACTER ORDER + INTEGER I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE, + $ INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU, + $ INDWK, INDWKN, ISCALE, J, JJ, LIWMIN, + $ LLWORK, LLWRKN, LWMIN, NSPLIT, + $ LHTRD, LWTRD, KD, IB, INDHOUS + DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DORMTR, DSCAL, DSTEBZ, DSTEMR, DSTEIN, + $ DSTERF, DSWAP, DSYTRD_2STAGE, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + IEEEOK = ILAENV( 10, 'DSYEVR', 'N', 1, 2, 3, 4 ) +* + LOWER = LSAME( UPLO, 'L' ) + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) +* + LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) ) +* + KD = ILAENV( 17, 'DSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'DSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = MAX( 26*N, 5*N + LHTRD + LWTRD ) + LIWMIN = MAX( 1, 10*N ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -8 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -10 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -15 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -18 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -20 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN +* NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) +* NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) ) +* LWKOPT = MAX( ( NB+1 )*N, LWMIN ) + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYEVR_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( N.EQ.1 ) THEN + WORK( 1 ) = 7 + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + ELSE + IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + END IF + END IF + IF( WANTZ ) THEN + Z( 1, 1 ) = ONE + ISUPPZ( 1 ) = 1 + ISUPPZ( 2 ) = 1 + END IF + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF (VALEIG) THEN + VLL = VL + VUU = VU + END IF + ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) + 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 + IF( LOWER ) THEN + DO 10 J = 1, N + CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL DSCAL( J, SIGMA, A( 1, J ), 1 ) + 20 CONTINUE + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF + +* Initialize indices into workspaces. Note: The IWORK indices are +* used only if DSTERF or DSTEMR fail. + +* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the +* elementary reflectors used in DSYTRD. + INDTAU = 1 +* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. + INDD = INDTAU + N +* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the +* tridiagonal matrix from DSYTRD. + INDE = INDD + N +* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over +* -written by DSTEMR (the DSTERF path copies the diagonal to W). + INDDD = INDE + N +* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over +* -written while computing the eigenvalues in DSTERF and DSTEMR. + INDEE = INDDD + N +* INDHOUS is the starting offset Householder storage of stage 2 + INDHOUS = INDEE + N +* INDWK is the starting offset of the left-over workspace, and +* LLWORK is the remaining workspace size. + INDWK = INDHOUS + LHTRD + LLWORK = LWORK - INDWK + 1 + + +* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and +* stores the block indices of each of the M<=N eigenvalues. + INDIBL = 1 +* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and +* stores the starting and finishing indices of each block. + INDISP = INDIBL + N +* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors +* that corresponding to eigenvectors that fail to converge in +* DSTEIN. This information is discarded; if any fail, the driver +* returns INFO > 0. + INDIFL = INDISP + N +* INDIWO is the offset of the remaining integer workspace. + INDIWO = INDIFL + N + +* +* Call DSYTRD_2STAGE to reduce symmetric matrix to tridiagonal form. +* +* + CALL DSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, WORK( INDD ), + $ WORK( INDE ), WORK( INDTAU ), WORK( INDHOUS ), + $ LHTRD, WORK( INDWK ), LLWORK, IINFO ) +* +* If all eigenvalues are desired +* then call DSTERF or DSTEMR and DORMTR. +* + IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. + $ IEEEOK.EQ.1 ) THEN + IF( .NOT.WANTZ ) THEN + CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTERF( N, W, WORK( INDEE ), INFO ) + ELSE + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 ) +* + IF (ABSTOL .LE. TWO*N*EPS) THEN + TRYRAC = .TRUE. + ELSE + TRYRAC = .FALSE. + END IF + CALL DSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ), + $ VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ, + $ TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK, + $ INFO ) +* +* +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by DSTEMR. +* + IF( WANTZ .AND. INFO.EQ.0 ) THEN + INDWKN = INDE + LLWRKN = LWORK - INDWKN + 1 + CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, + $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), + $ LLWRKN, IINFO ) + END IF + END IF +* +* + IF( INFO.EQ.0 ) THEN +* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are +* undefined. + M = N + GO TO 30 + END IF + INFO = 0 + END IF +* +* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. +* Also call DSTEBZ and DSTEIN if DSTEMR fails. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ WORK( INDWK ), IWORK( INDIWO ), IWORK( INDIFL ), + $ INFO ) +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by DSTEIN. +* + INDWKN = INDE + LLWRKN = LWORK - INDWKN + 1 + CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* +* Jump here if DSTEMR/DSTEIN succeeded. + 30 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. Note: We do not sort the IFAIL portion of IWORK. +* It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do +* not return this detailed information to the user. +* + IF( WANTZ ) THEN + DO 50 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 40 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 40 CONTINUE +* + IF( I.NE.0 ) THEN + W( I ) = W( J ) + W( J ) = TMP1 + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + END IF + 50 CONTINUE + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of DSYEVR_2STAGE +* + END diff --git a/math/lapack/src/main/fortran/dsyevx.f b/math/lapack/src/main/fortran/dsyevx.f new file mode 100644 index 0000000000..2fd7bce6b0 --- /dev/null +++ b/math/lapack/src/main/fortran/dsyevx.f @@ -0,0 +1,554 @@ +*> \brief DSYEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, +* ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, +* IFAIL, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYEVX computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric matrix A. Eigenvalues and eigenvectors can be +*> selected by specifying either a range of values or a range of indices +*> for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, the lower triangle (if UPLO='L') or the upper +*> triangle (if UPLO='U') of A, including the diagonal, is +*> destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing A to tridiagonal form. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*DLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*DLAMCH('S'). +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> On normal exit, the first M elements contain the selected +*> eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If an eigenvector fails to converge, then that column of Z +*> contains the latest approximation to the eigenvector, and the +*> index of the eigenvector is returned in IFAIL. +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise 8*N. +*> For optimal efficiency, LWORK >= (NB+3)*N, +*> where NB is the max of the blocksize for DSYTRD and DORMTR +*> returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (N) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvectors that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, then i eigenvectors failed to converge. +*> Their indices are stored in array IFAIL. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleSYeigen +* +* ===================================================================== + SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, + $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, + $ IFAIL, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, + $ WANTZ + CHARACTER ORDER + INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE, + $ ITMP1, J, JJ, LLWORK, LLWRKN, LWKMIN, + $ LWKOPT, NB, NSPLIT + DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ, + $ DSTEIN, DSTEQR, DSTERF, DSWAP, DSYTRD, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + LOWER = LSAME( UPLO, 'L' ) + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -8 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -10 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -15 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWKMIN = 1 + WORK( 1 ) = LWKMIN + ELSE + LWKMIN = 8*N + NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) + NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) ) + LWKOPT = MAX( LWKMIN, ( NB + 3 )*N ) + WORK( 1 ) = LWKOPT + END IF +* + IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) + $ INFO = -17 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYEVX', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) THEN + RETURN + END IF +* + IF( N.EQ.1 ) THEN + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + ELSE + IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + END IF + END IF + 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 = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF( VALEIG ) THEN + VLL = VL + VUU = VU + END IF + ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) + 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 + IF( LOWER ) THEN + DO 10 J = 1, N + CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL DSCAL( J, SIGMA, A( 1, J ), 1 ) + 20 CONTINUE + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF +* +* Call DSYTRD to reduce symmetric matrix to tridiagonal form. +* + INDTAU = 1 + INDE = INDTAU + N + INDD = INDE + N + INDWRK = INDD + N + LLWORK = LWORK - INDWRK + 1 + CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ), + $ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO ) +* +* If all eigenvalues are desired and ABSTOL is less than or equal to +* zero, then call DSTERF or DORGTR and SSTEQR. If this fails for +* some eigenvalue, then try DSTEBZ. +* + TEST = .FALSE. + IF( INDEIG ) THEN + IF( IL.EQ.1 .AND. IU.EQ.N ) THEN + TEST = .TRUE. + END IF + END IF + IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN + CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) + INDEE = INDWRK + 2*N + IF( .NOT.WANTZ ) THEN + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTERF( N, W, WORK( INDEE ), INFO ) + ELSE + CALL DLACPY( 'A', N, N, A, LDA, Z, LDZ ) + CALL DORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), + $ WORK( INDWRK ), LLWORK, IINFO ) + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, + $ WORK( INDWRK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 30 I = 1, N + IFAIL( I ) = 0 + 30 CONTINUE + END IF + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 40 + END IF + INFO = 0 + END IF +* +* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDIBL = 1 + INDISP = INDIBL + N + INDIWO = INDISP + N + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by DSTEIN. +* + INDWKN = INDE + LLWRKN = LWORK - INDWKN + 1 + CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 40 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 60 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 50 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 50 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 60 CONTINUE + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYEVX +* + END diff --git a/math/lapack/src/main/fortran/dsyevx_2stage.f b/math/lapack/src/main/fortran/dsyevx_2stage.f new file mode 100644 index 0000000000..97ca806fdd --- /dev/null +++ b/math/lapack/src/main/fortran/dsyevx_2stage.f @@ -0,0 +1,608 @@ +*> \brief DSYEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYEVX_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, +* IL, IU, ABSTOL, M, W, Z, LDZ, WORK, +* LWORK, IWORK, IFAIL, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric matrix A using the 2stage technique for +*> the reduction to tridiagonal. Eigenvalues and eigenvectors can be +*> selected by specifying either a range of values or a range of indices +*> for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, the lower triangle (if UPLO='L') or the upper +*> triangle (if UPLO='U') of A, including the diagonal, is +*> destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing A to tridiagonal form. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*DLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*DLAMCH('S'). +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> On normal exit, the first M elements contain the selected +*> eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If an eigenvector fails to converge, then that column of Z +*> contains the latest approximation to the eigenvector, and the +*> index of the eigenvector is returned in IFAIL. +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, 8*N, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + 3*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + 3*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (N) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvectors that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, then i eigenvectors failed to converge. +*> Their indices are stored in array IFAIL. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleSYeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, + $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, + $ LWORK, IWORK, IFAIL, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, + $ WANTZ + CHARACTER ORDER + INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE, + $ ITMP1, J, JJ, LLWORK, LLWRKN, + $ NSPLIT, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS + DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ, + $ DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA, + $ DSYTRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + LOWER = LSAME( UPLO, 'L' ) + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -8 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -10 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -15 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + WORK( 1 ) = LWMIN + ELSE + KD = ILAENV( 17, 'DSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'DSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = MAX( 8*N, 3*N + LHTRD + LWTRD ) + WORK( 1 ) = LWMIN + END IF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -17 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYEVX_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) THEN + RETURN + END IF +* + IF( N.EQ.1 ) THEN + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + ELSE + IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + END IF + END IF + 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 = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF( VALEIG ) THEN + VLL = VL + VUU = VU + END IF + ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) + 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 + IF( LOWER ) THEN + DO 10 J = 1, N + CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL DSCAL( J, SIGMA, A( 1, J ), 1 ) + 20 CONTINUE + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF +* +* Call DSYTRD_2STAGE to reduce symmetric matrix to tridiagonal form. +* + INDTAU = 1 + INDE = INDTAU + N + INDD = INDE + N + INDHOUS = INDD + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL DSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, WORK( INDD ), + $ WORK( INDE ), WORK( INDTAU ), WORK( INDHOUS ), + $ LHTRD, WORK( INDWRK ), LLWORK, IINFO ) +* +* If all eigenvalues are desired and ABSTOL is less than or equal to +* zero, then call DSTERF or DORGTR and SSTEQR. If this fails for +* some eigenvalue, then try DSTEBZ. +* + TEST = .FALSE. + IF( INDEIG ) THEN + IF( IL.EQ.1 .AND. IU.EQ.N ) THEN + TEST = .TRUE. + END IF + END IF + IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN + CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) + INDEE = INDWRK + 2*N + IF( .NOT.WANTZ ) THEN + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTERF( N, W, WORK( INDEE ), INFO ) + ELSE + CALL DLACPY( 'A', N, N, A, LDA, Z, LDZ ) + CALL DORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), + $ WORK( INDWRK ), LLWORK, IINFO ) + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, + $ WORK( INDWRK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 30 I = 1, N + IFAIL( I ) = 0 + 30 CONTINUE + END IF + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 40 + END IF + INFO = 0 + END IF +* +* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDIBL = 1 + INDISP = INDIBL + N + INDIWO = INDISP + N + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by DSTEIN. +* + INDWKN = INDE + LLWRKN = LWORK - INDWKN + 1 + CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 40 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 60 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 50 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 50 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 60 CONTINUE + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of DSYEVX_2STAGE +* + END diff --git a/math/lapack/src/main/fortran/dsygs2.f b/math/lapack/src/main/fortran/dsygs2.f new file mode 100644 index 0000000000..a54955c01e --- /dev/null +++ b/math/lapack/src/main/fortran/dsygs2.f @@ -0,0 +1,283 @@ +*> \brief \b DSYGS2 reduces a symmetric definite generalized eigenproblem to standard form, using the factorization results obtained from spotrf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYGS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, ITYPE, LDA, LDB, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYGS2 reduces a real symmetric-definite generalized eigenproblem +*> to standard form. +*> +*> If ITYPE = 1, the problem is A*x = lambda*B*x, +*> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) +*> +*> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or +*> B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T *A*L. +*> +*> B must have been previously factorized as U**T *U or L*L**T by DPOTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is 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. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored, and how B has been factorized. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n by n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n by n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the transformed matrix, stored in the +*> same format as A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> The triangular factor from the Cholesky factorization of B, +*> as returned by DPOTRF. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, ITYPE, LDA, LDB, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, HALF + PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K + DOUBLE PRECISION AKK, BKK, CT +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DSCAL, DSYR2, DTRMV, DTRSV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. 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 + 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( 'DSYGS2', -INFO ) + RETURN + END IF +* + IF( ITYPE.EQ.1 ) THEN + IF( UPPER ) THEN +* +* Compute inv(U**T)*A*inv(U) +* + DO 10 K = 1, N +* +* Update the upper triangle of A(k:n,k:n) +* + AKK = A( K, K ) + BKK = B( K, K ) + AKK = AKK / BKK**2 + A( K, K ) = AKK + IF( K.LT.N ) THEN + CALL DSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA ) + CT = -HALF*AKK + CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), + $ LDA ) + CALL DSYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA, + $ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA ) + CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), + $ LDA ) + CALL DTRSV( UPLO, 'Transpose', 'Non-unit', N-K, + $ B( K+1, K+1 ), LDB, A( K, K+1 ), LDA ) + END IF + 10 CONTINUE + ELSE +* +* Compute inv(L)*A*inv(L**T) +* + DO 20 K = 1, N +* +* Update the lower triangle of A(k:n,k:n) +* + AKK = A( K, K ) + BKK = B( K, K ) + AKK = AKK / BKK**2 + A( K, K ) = AKK + IF( K.LT.N ) THEN + CALL DSCAL( N-K, ONE / BKK, A( K+1, K ), 1 ) + CT = -HALF*AKK + CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) + CALL DSYR2( UPLO, N-K, -ONE, A( K+1, K ), 1, + $ B( K+1, K ), 1, A( K+1, K+1 ), LDA ) + CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) + CALL DTRSV( UPLO, 'No transpose', 'Non-unit', N-K, + $ B( K+1, K+1 ), LDB, A( K+1, K ), 1 ) + END IF + 20 CONTINUE + END IF + ELSE + IF( UPPER ) THEN +* +* Compute U*A*U**T +* + DO 30 K = 1, N +* +* Update the upper triangle of A(1:k,1:k) +* + AKK = A( K, K ) + BKK = B( K, K ) + CALL DTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B, + $ LDB, A( 1, K ), 1 ) + CT = HALF*AKK + CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) + CALL DSYR2( UPLO, K-1, ONE, A( 1, K ), 1, B( 1, K ), 1, + $ A, LDA ) + CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) + CALL DSCAL( K-1, BKK, A( 1, K ), 1 ) + A( K, K ) = AKK*BKK**2 + 30 CONTINUE + ELSE +* +* Compute L**T *A*L +* + DO 40 K = 1, N +* +* Update the lower triangle of A(1:k,1:k) +* + AKK = A( K, K ) + BKK = B( K, K ) + CALL DTRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB, + $ A( K, 1 ), LDA ) + CT = HALF*AKK + CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) + CALL DSYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ), + $ LDB, A, LDA ) + CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) + CALL DSCAL( K-1, BKK, A( K, 1 ), LDA ) + A( K, K ) = AKK*BKK**2 + 40 CONTINUE + END IF + END IF + RETURN +* +* End of DSYGS2 +* + END diff --git a/math/lapack/src/main/fortran/dsygst.f b/math/lapack/src/main/fortran/dsygst.f new file mode 100644 index 0000000000..5055acdf1d --- /dev/null +++ b/math/lapack/src/main/fortran/dsygst.f @@ -0,0 +1,321 @@ +*> \brief \b DSYGST +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, ITYPE, LDA, LDB, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYGST reduces a real symmetric-definite generalized eigenproblem +*> to standard form. +*> +*> If ITYPE = 1, the problem is A*x = lambda*B*x, +*> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) +*> +*> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or +*> B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. +*> +*> B must have been previously factorized as U**T*U or L*L**T by DPOTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is 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. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the transformed matrix, stored in the +*> same format as A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> The triangular factor from the Cholesky factorization of B, +*> as returned by DPOTRF. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, ITYPE, LDA, LDB, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, HALF + PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, KB, NB +* .. +* .. External Subroutines .. + EXTERNAL DSYGS2, DSYMM, DSYR2K, DTRMM, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. 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 + 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( 'DSYGST', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'DSYGST', UPLO, N, -1, -1, -1 ) +* + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) + ELSE +* +* Use blocked code +* + IF( ITYPE.EQ.1 ) THEN + IF( UPPER ) THEN +* +* Compute inv(U**T)*A*inv(U) +* + DO 10 K = 1, N, NB + KB = MIN( N-K+1, NB ) +* +* Update the upper triangle of A(k:n,k:n) +* + CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, + $ B( K, K ), LDB, INFO ) + IF( K+KB.LE.N ) THEN + CALL DTRSM( 'Left', UPLO, 'Transpose', 'Non-unit', + $ KB, N-K-KB+1, ONE, B( K, K ), LDB, + $ A( K, K+KB ), LDA ) + CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, + $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, + $ A( K, K+KB ), LDA ) + CALL DSYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE, + $ A( K, K+KB ), LDA, B( K, K+KB ), LDB, + $ ONE, A( K+KB, K+KB ), LDA ) + CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, + $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, + $ A( K, K+KB ), LDA ) + CALL DTRSM( 'Right', UPLO, 'No transpose', + $ 'Non-unit', KB, N-K-KB+1, ONE, + $ B( K+KB, K+KB ), LDB, A( K, K+KB ), + $ LDA ) + END IF + 10 CONTINUE + ELSE +* +* Compute inv(L)*A*inv(L**T) +* + DO 20 K = 1, N, NB + KB = MIN( N-K+1, NB ) +* +* Update the lower triangle of A(k:n,k:n) +* + CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, + $ B( K, K ), LDB, INFO ) + IF( K+KB.LE.N ) THEN + CALL DTRSM( 'Right', UPLO, 'Transpose', 'Non-unit', + $ N-K-KB+1, KB, ONE, B( K, K ), LDB, + $ A( K+KB, K ), LDA ) + CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, + $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, + $ A( K+KB, K ), LDA ) + CALL DSYR2K( UPLO, 'No transpose', N-K-KB+1, KB, + $ -ONE, A( K+KB, K ), LDA, B( K+KB, K ), + $ LDB, ONE, A( K+KB, K+KB ), LDA ) + CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, + $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, + $ A( K+KB, K ), LDA ) + CALL DTRSM( 'Left', UPLO, 'No transpose', + $ 'Non-unit', N-K-KB+1, KB, ONE, + $ B( K+KB, K+KB ), LDB, A( K+KB, K ), + $ LDA ) + END IF + 20 CONTINUE + END IF + ELSE + IF( UPPER ) THEN +* +* Compute U*A*U**T +* + DO 30 K = 1, N, NB + KB = MIN( N-K+1, NB ) +* +* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) +* + CALL DTRMM( 'Left', UPLO, 'No transpose', 'Non-unit', + $ K-1, KB, ONE, B, LDB, A( 1, K ), LDA ) + CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), + $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) + CALL DSYR2K( UPLO, 'No transpose', K-1, KB, ONE, + $ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A, + $ LDA ) + CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), + $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) + CALL DTRMM( 'Right', UPLO, 'Transpose', 'Non-unit', + $ K-1, KB, ONE, B( K, K ), LDB, A( 1, K ), + $ LDA ) + CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, + $ B( K, K ), LDB, INFO ) + 30 CONTINUE + ELSE +* +* Compute L**T*A*L +* + DO 40 K = 1, N, NB + KB = MIN( N-K+1, NB ) +* +* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) +* + CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', + $ KB, K-1, ONE, B, LDB, A( K, 1 ), LDA ) + CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), + $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) + CALL DSYR2K( UPLO, 'Transpose', K-1, KB, ONE, + $ A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A, + $ LDA ) + CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), + $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) + CALL DTRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB, + $ K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA ) + CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, + $ B( K, K ), LDB, INFO ) + 40 CONTINUE + END IF + END IF + END IF + RETURN +* +* End of DSYGST +* + END diff --git a/math/lapack/src/main/fortran/dsygv.f b/math/lapack/src/main/fortran/dsygv.f new file mode 100644 index 0000000000..651abc5c7b --- /dev/null +++ b/math/lapack/src/main/fortran/dsygv.f @@ -0,0 +1,314 @@ +*> \brief \b DSYGV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, ITYPE, LDA, LDB, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYGV computes all the eigenvalues, and optionally, the eigenvectors +*> of a real generalized symmetric-definite eigenproblem, of the form +*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. +*> Here A and B are assumed to be symmetric and B is also +*> positive definite. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is 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 +*> \endverbatim +*> +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangles of A and B are stored; +*> = 'L': Lower triangles of A and B are stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> matrix Z of eigenvectors. The eigenvectors are normalized +*> as follows: +*> if ITYPE = 1 or 2, Z**T*B*Z = I; +*> if ITYPE = 3, Z**T*inv(B)*Z = I. +*> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') +*> or the lower triangle (if UPLO='L') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB, N) +*> On entry, the symmetric positive definite matrix B. +*> If UPLO = 'U', the leading N-by-N upper triangular part of B +*> contains the upper triangular part of the matrix B. +*> If UPLO = 'L', the leading N-by-N lower triangular part of B +*> contains the lower triangular part of the matrix B. +*> +*> On exit, if INFO <= N, the part of B containing the matrix is +*> overwritten by the triangular factor U or L from the Cholesky +*> factorization B = U**T*U or B = L*L**T. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: DPOTRF or DSYEV returned an error code: +*> <= N: if INFO = i, DSYEV failed to converge; +*> i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> > N: if INFO = N + i, for 1 <= i <= N, then the leading +*> minor of order i of B is not positive definite. +*> The factorization of B could not be completed and +*> no eigenvalues or eigenvectors were computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYeigen +* +* ===================================================================== + SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, ITYPE, LDA, LDB, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER, WANTZ + CHARACTER TRANS + INTEGER LWKMIN, LWKOPT, NB, NEIG +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DPOTRF, DSYEV, DSYGST, DTRMM, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* + 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( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKMIN = MAX( 1, 3*N - 1 ) + NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( LWKMIN, ( NB + 2 )*N ) + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYGV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Form a Cholesky factorization of B. +* + CALL DPOTRF( UPLO, N, B, LDB, INFO ) + IF( INFO.NE.0 ) THEN + INFO = N + INFO + RETURN + END IF +* +* Transform problem to standard eigenvalue problem and solve. +* + CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) + CALL DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, 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)**T*y or inv(U)*y +* + IF( UPPER ) THEN + TRANS = 'N' + ELSE + TRANS = 'T' + END IF +* + CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, + $ B, LDB, A, LDA ) +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* For B*A*x=(lambda)*x; +* backtransform eigenvectors: x = L*y or U**T*y +* + IF( UPPER ) THEN + TRANS = 'T' + ELSE + TRANS = 'N' + END IF +* + CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, + $ B, LDB, A, LDA ) + END IF + END IF +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of DSYGV +* + END diff --git a/math/lapack/src/main/fortran/dsygv_2stage.f b/math/lapack/src/main/fortran/dsygv_2stage.f new file mode 100644 index 0000000000..b7da00f517 --- /dev/null +++ b/math/lapack/src/main/fortran/dsygv_2stage.f @@ -0,0 +1,370 @@ +*> \brief \b DSYGV_2STAGE +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYGV_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYGV_2STAGE( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, +* WORK, LWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, ITYPE, LDA, LDB, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYGV_2STAGE computes all the eigenvalues, and optionally, the eigenvectors +*> of a real generalized symmetric-definite eigenproblem, of the form +*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. +*> Here A and B are assumed to be symmetric and B is also +*> positive definite. +*> This routine use the 2stage technique for the reduction to tridiagonal +*> which showed higher performance on recent architecture and for large +* sizes N>2000. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is 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 +*> \endverbatim +*> +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangles of A and B are stored; +*> = 'L': Lower triangles of A and B are stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> matrix Z of eigenvectors. The eigenvectors are normalized +*> as follows: +*> if ITYPE = 1 or 2, Z**T*B*Z = I; +*> if ITYPE = 3, Z**T*inv(B)*Z = I. +*> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') +*> or the lower triangle (if UPLO='L') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB, N) +*> On entry, the symmetric positive definite matrix B. +*> If UPLO = 'U', the leading N-by-N upper triangular part of B +*> contains the upper triangular part of the matrix B. +*> If UPLO = 'L', the leading N-by-N lower triangular part of B +*> contains the lower triangular part of the matrix B. +*> +*> On exit, if INFO <= N, the part of B containing the matrix is +*> overwritten by the triangular factor U or L from the Cholesky +*> factorization B = U**T*U or B = L*L**T. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + 2*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + 2*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: DPOTRF or DSYEV returned an error code: +*> <= N: if INFO = i, DSYEV failed to converge; +*> i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> > N: if INFO = N + i, for 1 <= i <= N, then the leading +*> minor of order i of B is not positive definite. +*> The factorization of B could not be completed and +*> no eigenvalues or eigenvectors were computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYGV_2STAGE( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, + $ WORK, LWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, ITYPE, LDA, LDB, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER, WANTZ + CHARACTER TRANS + INTEGER NEIG, LWMIN, LHTRD, LWTRD, KD, IB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DPOTRF, DSYGST, DTRMM, DTRSM, XERBLA, + $ DSYEV_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN + INFO = -1 + ELSE IF( .NOT.( 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( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + KD = ILAENV( 17, 'DSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'DSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = 2*N + LHTRD + LWTRD + WORK( 1 ) = LWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYGV_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Form a Cholesky factorization of B. +* + CALL DPOTRF( UPLO, N, B, LDB, INFO ) + IF( INFO.NE.0 ) THEN + INFO = N + INFO + RETURN + END IF +* +* Transform problem to standard eigenvalue problem and solve. +* + CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) + CALL DSYEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, 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)**T*y or inv(U)*y +* + IF( UPPER ) THEN + TRANS = 'N' + ELSE + TRANS = 'T' + END IF +* + CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, + $ B, LDB, A, LDA ) +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* For B*A*x=(lambda)*x; +* backtransform eigenvectors: x = L*y or U**T*y +* + IF( UPPER ) THEN + TRANS = 'T' + ELSE + TRANS = 'N' + END IF +* + CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, + $ B, LDB, A, LDA ) + END IF + END IF +* + WORK( 1 ) = LWMIN + RETURN +* +* End of DSYGV_2STAGE +* + END diff --git a/math/lapack/src/main/fortran/dsygvd.f b/math/lapack/src/main/fortran/dsygvd.f new file mode 100644 index 0000000000..29c78283a7 --- /dev/null +++ b/math/lapack/src/main/fortran/dsygvd.f @@ -0,0 +1,380 @@ +*> \brief \b DSYGVD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYGVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, +* LWORK, IWORK, LIWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYGVD computes all the eigenvalues, and optionally, the eigenvectors +*> of a real generalized symmetric-definite eigenproblem, of the form +*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and +*> B are assumed to be symmetric and B is also positive definite. +*> If eigenvectors are desired, it uses a divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is 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 +*> \endverbatim +*> +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangles of A and B are stored; +*> = 'L': Lower triangles of A and B are stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> matrix Z of eigenvectors. The eigenvectors are normalized +*> as follows: +*> if ITYPE = 1 or 2, Z**T*B*Z = I; +*> if ITYPE = 3, Z**T*inv(B)*Z = I. +*> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') +*> or the lower triangle (if UPLO='L') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB, N) +*> On entry, the symmetric matrix B. If UPLO = 'U', the +*> leading N-by-N upper triangular part of B contains the +*> upper triangular part of the matrix B. If UPLO = 'L', +*> the leading N-by-N lower triangular part of B contains +*> the lower triangular part of the matrix B. +*> +*> On exit, if INFO <= N, the part of B containing the matrix is +*> overwritten by the triangular factor U or L from the Cholesky +*> factorization B = U**T*U or B = L*L**T. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If N <= 1, LWORK >= 1. +*> If JOBZ = 'N' and N > 1, LWORK >= 2*N+1. +*> If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK and IWORK +*> arrays, returns these values as the first entries of the WORK +*> and IWORK arrays, and no error message related to LWORK or +*> LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If N <= 1, LIWORK >= 1. +*> If JOBZ = 'N' and N > 1, LIWORK >= 1. +*> If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: DPOTRF or DSYEVD returned an error code: +*> <= N: if INFO = i and JOBZ = 'N', then the algorithm +*> failed to converge; i off-diagonal elements of an +*> intermediate tridiagonal form did not converge to +*> zero; +*> if INFO = i and JOBZ = 'V', then the algorithm +*> failed to compute an eigenvalue while working on +*> the submatrix lying in rows and columns INFO/(N+1) +*> through mod(INFO,N+1); +*> > N: if INFO = N + i, for 1 <= i <= N, then the leading +*> minor of order i of B is not positive definite. +*> The factorization of B could not be completed and +*> no eigenvalues or eigenvectors were computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Modified so that no backsubstitution is performed if DSYEVD fails to +*> converge (NEIG in old code could be greater than N causing out of +*> bounds reference to A - reported by Ralf Meyer). Also corrected the +*> description of INFO and the test on ITYPE. Sven, 16 Feb 05. +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA +*> +* ===================================================================== + SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, + $ LWORK, IWORK, LIWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER, WANTZ + CHARACTER TRANS + INTEGER LIOPT, LIWMIN, LOPT, LWMIN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DPOTRF, DSYEVD, DSYGST, DTRMM, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + INFO = 0 + IF( N.LE.1 ) THEN + LIWMIN = 1 + LWMIN = 1 + ELSE IF( WANTZ ) THEN + LIWMIN = 3 + 5*N + LWMIN = 1 + 6*N + 2*N**2 + ELSE + LIWMIN = 1 + LWMIN = 2*N + 1 + END IF + LOPT = LWMIN + LIOPT = LIWMIN + 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( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LOPT + IWORK( 1 ) = LIOPT +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYGVD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Form a Cholesky factorization of B. +* + CALL DPOTRF( UPLO, N, B, LDB, INFO ) + IF( INFO.NE.0 ) THEN + INFO = N + INFO + RETURN + END IF +* +* Transform problem to standard eigenvalue problem and solve. +* + CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) + CALL DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK, + $ INFO ) + LOPT = MAX( DBLE( LOPT ), DBLE( WORK( 1 ) ) ) + LIOPT = MAX( DBLE( LIOPT ), DBLE( IWORK( 1 ) ) ) +* + IF( WANTZ .AND. INFO.EQ.0 ) THEN +* +* Backtransform eigenvectors to the original problem. +* + 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)**T*y or inv(U)*y +* + IF( UPPER ) THEN + TRANS = 'N' + ELSE + TRANS = 'T' + END IF +* + CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE, + $ B, LDB, A, LDA ) +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* For B*A*x=(lambda)*x; +* backtransform eigenvectors: x = L*y or U**T*y +* + IF( UPPER ) THEN + TRANS = 'T' + ELSE + TRANS = 'N' + END IF +* + CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE, + $ B, LDB, A, LDA ) + END IF + END IF +* + WORK( 1 ) = LOPT + IWORK( 1 ) = LIOPT +* + RETURN +* +* End of DSYGVD +* + END diff --git a/math/lapack/src/main/fortran/dsygvx.f b/math/lapack/src/main/fortran/dsygvx.f new file mode 100644 index 0000000000..aeca6021de --- /dev/null +++ b/math/lapack/src/main/fortran/dsygvx.f @@ -0,0 +1,465 @@ +*> \brief \b DSYGVX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYGVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, +* VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, +* LWORK, IWORK, IFAIL, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYGVX computes selected eigenvalues, and optionally, eigenvectors +*> of a real generalized symmetric-definite eigenproblem, of the form +*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A +*> and B are assumed to be symmetric and B is also positive definite. +*> Eigenvalues and eigenvectors can be selected by specifying either a +*> range of values or a range of indices for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is 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 +*> \endverbatim +*> +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A and B are stored; +*> = 'L': Lower triangle of A and B are stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix pencil (A,B). N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> +*> On exit, the lower triangle (if UPLO='L') or the upper +*> triangle (if UPLO='U') of A, including the diagonal, is +*> destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB, N) +*> On entry, the symmetric matrix B. If UPLO = 'U', the +*> leading N-by-N upper triangular part of B contains the +*> upper triangular part of the matrix B. If UPLO = 'L', +*> the leading N-by-N lower triangular part of B contains +*> the lower triangular part of the matrix B. +*> +*> On exit, if INFO <= N, the part of B containing the matrix is +*> overwritten by the triangular factor U or L from the Cholesky +*> factorization B = U**T*U or B = L*L**T. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing C to tridiagonal form, where C is the symmetric +*> matrix of the standard symmetric problem to which the +*> generalized problem is transformed. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*DLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*DLAMCH('S'). +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> On normal exit, the first M elements contain the selected +*> eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'N', then Z is not referenced. +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> The eigenvectors are normalized as follows: +*> if ITYPE = 1 or 2, Z**T*B*Z = I; +*> if ITYPE = 3, Z**T*inv(B)*Z = I. +*> +*> If an eigenvector fails to converge, then that column of Z +*> contains the latest approximation to the eigenvector, and the +*> index of the eigenvector is returned in IFAIL. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= max(1,8*N). +*> For optimal efficiency, LWORK >= (NB+3)*N, +*> where NB is the blocksize for DSYTRD returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (N) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvectors that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: DPOTRF or DSYEVX returned an error code: +*> <= N: if INFO = i, DSYEVX failed to converge; +*> i eigenvectors failed to converge. Their indices +*> are stored in array IFAIL. +*> > N: if INFO = N + i, for 1 <= i <= N, then the leading +*> minor of order i of B is not positive definite. +*> The factorization of B could not be completed and +*> no eigenvalues or eigenvectors were computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleSYeigen +* +*> \par Contributors: +* ================== +*> +*> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA +* +* ===================================================================== + SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, + $ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, + $ LWORK, IWORK, IFAIL, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ + CHARACTER TRANS + INTEGER LWKMIN, LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DPOTRF, DSYEVX, DSYGST, DTRMM, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + UPPER = LSAME( UPLO, 'U' ) + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) + LQUERY = ( LWORK.EQ.-1 ) +* + 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.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -3 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -4 + 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( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -11 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -13 + END IF + END IF + END IF + IF (INFO.EQ.0) THEN + IF (LDZ.LT.1 .OR. (WANTZ .AND. LDZ.LT.N)) THEN + INFO = -18 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + LWKMIN = MAX( 1, 8*N ) + NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( LWKMIN, ( NB + 3 )*N ) + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN + INFO = -20 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYGVX', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) THEN + RETURN + END IF +* +* Form a Cholesky factorization of B. +* + CALL DPOTRF( UPLO, N, B, LDB, INFO ) + IF( INFO.NE.0 ) THEN + INFO = N + INFO + RETURN + END IF +* +* Transform problem to standard eigenvalue problem and solve. +* + CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) + CALL DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, + $ M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO ) +* + IF( WANTZ ) THEN +* +* Backtransform eigenvectors to the original problem. +* + IF( INFO.GT.0 ) + $ M = 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)**T*y or inv(U)*y +* + IF( UPPER ) THEN + TRANS = 'N' + ELSE + TRANS = 'T' + END IF +* + CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B, + $ LDB, Z, LDZ ) +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* For B*A*x=(lambda)*x; +* backtransform eigenvectors: x = L*y or U**T*y +* + IF( UPPER ) THEN + TRANS = 'T' + ELSE + TRANS = 'N' + END IF +* + CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B, + $ LDB, Z, LDZ ) + END IF + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYGVX +* + END diff --git a/math/lapack/src/main/fortran/dsyrfs.f b/math/lapack/src/main/fortran/dsyrfs.f new file mode 100644 index 0000000000..2732f175be --- /dev/null +++ b/math/lapack/src/main/fortran/dsyrfs.f @@ -0,0 +1,441 @@ +*> \brief \b DSYRFS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, +* X, LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYRFS improves the computed solution to a system of linear +*> equations when the coefficient matrix is symmetric indefinite, and +*> provides error bounds and backward error estimates for the solution. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> The factored form of the matrix A. AF contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor U or L from the factorization A = U*D*U**T or +*> A = L*D*L**T as computed by DSYTRF. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> On entry, the solution matrix X, as computed by DSYTRS. +*> On exit, the improved solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> ITMAX is the maximum number of steps of iterative refinement. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, + $ X, LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + 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, * ) +* .. +* +* ===================================================================== +* +* .. 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 UPPER + 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, DLACN2, DSYMV, DSYTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. 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( 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( 'DSYRFS', -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 +* +* 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 - A * X +* + CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) + CALL DSYMV( UPLO, 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(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(A)*abs(X) + abs(B). +* + IF( UPPER ) THEN + DO 50 K = 1, N + S = ZERO + XK = ABS( X( K, J ) ) + DO 40 I = 1, K - 1 + WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK + S = S + ABS( A( I, K ) )*ABS( X( I, J ) ) + 40 CONTINUE + WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S + 50 CONTINUE + ELSE + DO 70 K = 1, N + S = ZERO + XK = ABS( X( K, J ) ) + WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + DO 60 I = K + 1, N + WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK + 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 DSYTRS( UPLO, 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(A))* +* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) +* +* where +* norm(Z) is the magnitude of the largest component of Z +* inv(A) is the inverse of A +* abs(Z) is the componentwise absolute value of the matrix or +* vector Z +* NZ is the maximum number of nonzeros in any row of A, plus 1 +* EPS is machine epsilon +* +* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) +* is incremented by SAFE1 if the i-th component of +* abs(A)*abs(X) + abs(B) is less than SAFE2. +* +* Use DLACN2 to estimate the infinity-norm of the matrix +* inv(A) * diag(W), +* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) +* + 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(A**T). +* + CALL DSYTRS( UPLO, 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 IF( KASE.EQ.2 ) THEN +* +* Multiply by inv(A)*diag(W). +* + DO 120 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 120 CONTINUE + CALL DSYTRS( UPLO, 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 DSYRFS +* + END diff --git a/math/lapack/src/main/fortran/dsyrfsx.f b/math/lapack/src/main/fortran/dsyrfsx.f new file mode 100644 index 0000000000..e128cd4e0f --- /dev/null +++ b/math/lapack/src/main/fortran/dsyrfsx.f @@ -0,0 +1,700 @@ +*> \brief \b DSYRFSX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYRFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, +* S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, +* ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, EQUED +* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, +* $ N_ERR_BNDS +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), +* $ X( LDX, * ), WORK( * ) +* DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), +* $ ERR_BNDS_NORM( NRHS, * ), +* $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYRFSX improves the computed solution to a system of linear +*> equations when the coefficient matrix is symmetric indefinite, and +*> provides error bounds and backward error estimates for the +*> solution. In addition to normwise error bound, the code provides +*> maximum componentwise error bound if possible. See comments for +*> ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds. +*> +*> The original system of linear equations may have been equilibrated +*> before calling this routine, as described by arguments EQUED and S +*> below. In this case, the solution and error bounds returned are +*> for the original unequilibrated system. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> Some optional parameters are bundled in the PARAMS array. These +*> settings determine how refinement is performed, but often the +*> defaults are acceptable. If the defaults are acceptable, users +*> can pass NPARAMS = 0 which prevents the source code from accessing +*> the PARAMS argument. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] EQUED +*> \verbatim +*> EQUED is CHARACTER*1 +*> Specifies the form of equilibration that was done to A +*> before calling this routine. This is needed to compute +*> the solution and error bounds correctly. +*> = 'N': No equilibration +*> = 'Y': Both row and column equilibration, i.e., A has been +*> replaced by diag(S) * A * diag(S). +*> The right hand side B has been changed accordingly. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> The factored form of the matrix A. AF contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor U or L from the factorization A = U*D*U**T or A = +*> L*D*L**T as computed by DSYTRF. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF. +*> \endverbatim +*> +*> \param[in,out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N) +*> The scale factors for A. If EQUED = 'Y', A is multiplied on +*> the left and right by diag(S). S is an input argument if FACT = +*> 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +*> = 'Y', each element of S must be positive. If S is output, each +*> element of S is a power of the radix. If S is input, each element +*> of S should be a power of the radix to ensure a reliable solution +*> and error estimates. Scaling by powers of the radix does not cause +*> rounding errors unless the result underflows or overflows. +*> Rounding errors during scaling lead to refining with a matrix that +*> is not equivalent to the input matrix, producing error estimates +*> that may not be reliable. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> On entry, the solution matrix X, as computed by DGETRS. +*> On exit, the improved solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> Reciprocal scaled condition number. This is an estimate of the +*> reciprocal Skeel condition number of the matrix A after +*> equilibration (if done). If this is less than the machine +*> precision (in particular, if it is zero), the matrix is singular +*> to working precision. Note that the error may still be small even +*> if this number is very small and the matrix appears ill- +*> conditioned. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is DOUBLE PRECISION array, dimension (NRHS) +*> Componentwise relative backward error. This is the +*> componentwise relative backward error of each solution vector X(j) +*> (i.e., the smallest relative change in any element of A or B that +*> makes X(j) an exact solution). +*> \endverbatim +*> +*> \param[in] N_ERR_BNDS +*> \verbatim +*> N_ERR_BNDS is INTEGER +*> Number of error bounds to return for each right hand side +*> and each type (normwise or componentwise). See ERR_BNDS_NORM and +*> ERR_BNDS_COMP below. +*> \endverbatim +*> +*> \param[out] ERR_BNDS_NORM +*> \verbatim +*> ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> normwise relative error, which is defined as follows: +*> +*> Normwise relative error in the ith solution vector: +*> max_j (abs(XTRUE(j,i) - X(j,i))) +*> ------------------------------ +*> max_j abs(X(j,i)) +*> +*> The array is indexed by the type of error information as described +*> below. There currently are up to three pieces of information +*> returned. +*> +*> The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_NORM(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * dlamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * dlamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated normwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * dlamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*A, where S scales each row by a power of the +*> radix so all absolute row sums of Z are approximately 1. +*> +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[out] ERR_BNDS_COMP +*> \verbatim +*> ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> componentwise relative error, which is defined as follows: +*> +*> Componentwise relative error in the ith solution vector: +*> abs(XTRUE(j,i) - X(j,i)) +*> max_j ---------------------- +*> abs(X(j,i)) +*> +*> The array is indexed by the right-hand side i (on which the +*> componentwise relative error depends), and the type of error +*> information as described below. There currently are up to three +*> pieces of information returned for each right-hand side. If +*> componentwise accuracy is not requested (PARAMS(3) = 0.0), then +*> ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +*> the first (:,N_ERR_BNDS) entries are returned. +*> +*> The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_COMP(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * dlamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * dlamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated componentwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * dlamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*(A*diag(x)), where x is the solution for the +*> current right-hand side and S scales each row of +*> A*diag(x) by a power of the radix so all absolute row +*> sums of Z are approximately 1. +*> +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[in] NPARAMS +*> \verbatim +*> NPARAMS is INTEGER +*> Specifies the number of parameters set in PARAMS. If .LE. 0, the +*> PARAMS array is never referenced and default values are used. +*> \endverbatim +*> +*> \param[in,out] PARAMS +*> \verbatim +*> PARAMS is DOUBLE PRECISION array, dimension (NPARAMS) +*> Specifies algorithm parameters. If an entry is .LT. 0.0, then +*> that entry will be filled with default value used for that +*> parameter. Only positions up to NPARAMS are accessed; defaults +*> are used for higher-numbered parameters. +*> +*> PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +*> refinement or not. +*> Default: 1.0D+0 +*> = 0.0 : No refinement is performed, and no error bounds are +*> computed. +*> = 1.0 : Use the double-precision refinement algorithm, +*> possibly with doubled-single computations if the +*> compilation environment does not support DOUBLE +*> PRECISION. +*> (other values are reserved for future use) +*> +*> PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +*> computations allowed for refinement. +*> Default: 10 +*> Aggressive: Set to 100 to permit convergence using approximate +*> factorizations or factorizations other than LU. If +*> the factorization uses a technique other than +*> Gaussian elimination, the guarantees in +*> err_bnds_norm and err_bnds_comp may no longer be +*> trustworthy. +*> +*> PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +*> will attempt to find a solution with small componentwise +*> relative error in the double-precision algorithm. Positive +*> is true, 0.0 is false. +*> Default: 1.0 (attempt componentwise convergence) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Successful exit. The solution to every right-hand side is +*> guaranteed. +*> < 0: If INFO = -i, the i-th argument had an illegal value +*> > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +*> has been completed, but the factor U is exactly singular, so +*> the solution and error bounds could not be computed. RCOND = 0 +*> is returned. +*> = N+J: The solution corresponding to the Jth right-hand side is +*> not guaranteed. The solutions corresponding to other right- +*> hand sides K with K > J may not be guaranteed as well, but +*> only the first such right-hand side is reported. If a small +*> componentwise error is not requested (PARAMS(3) = 0.0) then +*> the Jth right-hand side is the first with a normwise error +*> bound that is not guaranteed (the smallest J such +*> that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +*> the Jth right-hand side is the first with either a normwise or +*> componentwise error bound that is not guaranteed (the smallest +*> J such that either ERR_BNDS_NORM(J,1) = 0.0 or +*> ERR_BNDS_COMP(J,1) = 0.0). See the definition of +*> ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +*> about all of the right-hand sides check ERR_BNDS_NORM or +*> ERR_BNDS_COMP. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT + DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT + DOUBLE PRECISION DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0D+0 ) + PARAMETER ( ITHRESH_DEFAULT = 10.0D+0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0D+0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5D+0 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25D+0 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL RCEQU + INTEGER J, PREC_TYPE, REF_TYPE, N_NORMS + DOUBLE PRECISION ANORM, RCOND_TMP + DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSYCON, DLA_SYRFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, ILAPREC + EXTERNAL DLAMCH, DLANSY, DLA_SYRCOND + DOUBLE PRECISION DLAMCH, DLANSY, DLA_SYRCOND + LOGICAL LSAME + INTEGER ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0D+0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = DBLE( N )*DLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0D+0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0D+0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0D+0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0D+0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0D+0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0D+0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + RCEQU = LSAME( EQUED, 'Y' ) +* +* Test input parameters. +* + IF ( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.RCEQU .AND. .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYRFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0D+0 + DO J = 1, NRHS + BERR( J ) = 0.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF + IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0D+0 + END IF + IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0D+0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0D+0 + DO J = 1, NRHS + BERR( J ) = 1.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF + IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + END IF + IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0D+0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + NORM = 'I' + ANORM = DLANSY( NORM, UPLO, N, A, LDA, WORK ) + CALL DSYCON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, + $ IWORK, INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'E' ) + + CALL DLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, RCEQU, S, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ WORK( N+1 ), WORK( 1 ), WORK( 2*N+1 ), WORK( 1 ), RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + END IF + + ERR_LBND = MAX( 10.0D+0, SQRT( DBLE( N ) ) )*DLAMCH( 'Epsilon' ) + IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( RCEQU ) THEN + RCOND_TMP = DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ -1, S, INFO, WORK, IWORK ) + ELSE + RCOND_TMP = DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ 0, S, INFO, WORK, IWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF (N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0D+0) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF (ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF (N_ERR_BNDS .GE. LA_LINRX_RCOND_I) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF + + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2 ) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( DLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ 1, X(1,J), INFO, WORK, IWORK ) + ELSE + RCOND_TMP = 0.0D+0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( .NOT. IGNORE_CWISE + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of DSYRFSX +* + END diff --git a/math/lapack/src/main/fortran/dsysv.f b/math/lapack/src/main/fortran/dsysv.f new file mode 100644 index 0000000000..c9811b5666 --- /dev/null +++ b/math/lapack/src/main/fortran/dsysv.f @@ -0,0 +1,270 @@ +*> \brief DSYSV computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, as +*> determined by DSYTRF. 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. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1, and for best performance +*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for +*> DSYTRF. +*> for LWORK < N, TRS will be done with Level BLAS 2 +*> for LWORK >= N, TRS will be done with Level BLAS 3 +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYsolve +* +* ===================================================================== + SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSYTRF, DSYTRS, DSYTRS2 +* .. +* .. 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 + CALL DSYTRF( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + LWKOPT = WORK(1) + 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**T or A = L*D*L**T. +* + 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. +* + IF ( LWORK.LT.N ) THEN +* +* Solve with TRS ( Use Level BLAS 2) +* + CALL DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* + ELSE +* +* Solve with TRS2 ( Use Level BLAS 3) +* + CALL DSYTRS2( UPLO,N,NRHS,A,LDA,IPIV,B,LDB,WORK,INFO ) +* + END IF +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYSV +* + END diff --git a/math/lapack/src/main/fortran/dsysv_aa.f b/math/lapack/src/main/fortran/dsysv_aa.f new file mode 100644 index 0000000000..e458f12bbd --- /dev/null +++ b/math/lapack/src/main/fortran/dsysv_aa.f @@ -0,0 +1,256 @@ +*> \brief DSYSV_AA computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYSV_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYSV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> +*> Aasen's algorithm is used to factor A as +*> A = U * T * U**T, if UPLO = 'U', or +*> A = L * T * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is symmetric tridiagonal. The factored +*> form of A is then used to solve the system of equations A * X = B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the tridiagonal matrix T and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*T*U**T or A = L*T*L**T as computed by +*> DSYTRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= MAX(1,2*N,3*N-2), and for +*> the best performance, LWORK >= MAX(1,N*NB), where NB is +*> the optimal blocksize for DSYTRF_AA. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +* @precisions fortran d -> z c +* +*> \ingroup doubleSYsolve +* +* ===================================================================== + SUBROUTINE DSYSV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT, LWKOPT_SYTRF, LWKOPT_SYTRS +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSYTRF, DSYTRS, DSYTRS2 +* .. +* .. 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.MAX(2*N, 3*N-2) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + CALL DSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + LWKOPT_SYTRF = INT( WORK(1) ) + CALL DSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ -1, INFO ) + LWKOPT_SYTRS = INT( WORK(1) ) + LWKOPT = MAX( LWKOPT_SYTRF, LWKOPT_SYTRS ) + WORK( 1 ) = LWKOPT + IF( LWORK.LT.LWKOPT .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYSV_AA ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*T*U**T or A = L*T*L**T. +* + CALL DSYTRF_AA( 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_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYSV_AA +* + END diff --git a/math/lapack/src/main/fortran/dsysv_rk.f b/math/lapack/src/main/fortran/dsysv_rk.f new file mode 100644 index 0000000000..6a6036be19 --- /dev/null +++ b/math/lapack/src/main/fortran/dsysv_rk.f @@ -0,0 +1,317 @@ +*> \brief DSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYSV_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DSYSV_RK computes the solution to a real system of linear +*> equations A * X = B, where A is an N-by-N symmetric matrix +*> and X and B are N-by-NRHS matrices. +*> +*> The bounded Bunch-Kaufman (rook) diagonal pivoting method is used +*> to factor A as +*> A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or +*> A = P*L*D*(L**T)*(P**T), if UPLO = 'L', +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> DSYTRF_RK is called to compute the factorization of a real +*> symmetric matrix. The factored form of A is then used to solve +*> the system of equations A * X = B by calling BLAS3 routine DSYTRS_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, if INFO = 0, diagonal of the block diagonal +*> matrix D and factors U or L as computed by DSYTRF_RK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> For more info see the description of DSYTRF_RK routine. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On exit, contains the output computed by the factorization +*> routine DSYTRF_RK, i.e. the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> +*> For more info see the description of DSYTRF_RK routine. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by DSYTRF_RK. +*> +*> For more info see the description of DSYTRF_RK routine. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension ( MAX(1,LWORK) ). +*> Work array used in the factorization stage. +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1. For best performance +*> of factorization stage LWORK >= max(1,N*NB), where NB is +*> the optimal blocksize for DSYTRF_RK. +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array for factorization stage, returns this value as +*> the first entry of the WORK array, and no error message +*> related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYsolve +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSYTRF_RK, DSYTRS_3 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + CALL DSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, -1, INFO ) + LWKOPT = WORK(1) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYSV_RK ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = P*U*D*(U**T)*(P**T) or +* A = P*U*D*(U**T)*(P**T). +* + CALL DSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO ) +* + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B with BLAS3 solver, overwriting B with X. +* + CALL DSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYSV_RK +* + END diff --git a/math/lapack/src/main/fortran/dsysv_rook.f b/math/lapack/src/main/fortran/dsysv_rook.f new file mode 100644 index 0000000000..d69c176279 --- /dev/null +++ b/math/lapack/src/main/fortran/dsysv_rook.f @@ -0,0 +1,293 @@ +*> \brief DSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYSV_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYSV_ROOK 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. +*> +*> DSYTRF_ROOK is called to compute the factorization of a real +*> symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal +*> pivoting method. +*> +*> The factored form of A is then used to solve the system +*> of equations A * X = B by calling DSYTRS_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, 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_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by DSYTRF_ROOK. +*> +*> If UPLO = 'U': +*> 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 IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> 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 IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1, and for best performance +*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for +*> DSYTRF_ROOK. +*> +*> TRS will be done with Level 2 BLAS +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleSYsolve +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2012, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSYTRF_ROOK, DSYTRS_ROOK +* .. +* .. 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 + CALL DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + LWKOPT = WORK(1) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYSV_ROOK ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*D*U**T or A = L*D*L**T. +* + CALL DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* +* Solve with TRS_ROOK ( Use Level 2 BLAS) +* + CALL DSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYSV_ROOK +* + END diff --git a/math/lapack/src/main/fortran/dsysvx.f b/math/lapack/src/main/fortran/dsysvx.f new file mode 100644 index 0000000000..cd059863e0 --- /dev/null +++ b/math/lapack/src/main/fortran/dsysvx.f @@ -0,0 +1,416 @@ +*> \brief DSYSVX computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, +* LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, +* IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER FACT, UPLO +* INTEGER INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), +* $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYSVX uses the diagonal pivoting factorization to compute the +*> solution to a real system of linear equations A * X = B, +*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS +*> matrices. +*> +*> Error bounds on the solution and a condition estimate are also +*> provided. +*> \endverbatim +* +*> \par Description: +* ================= +*> +*> \verbatim +*> +*> The following steps are performed: +*> +*> 1. If FACT = 'N', the diagonal pivoting method is used to factor A. +*> The form of the factorization is +*> A = U * D * U**T, if UPLO = 'U', or +*> A = L * D * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is symmetric and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. +*> +*> 2. If some D(i,i)=0, so that D is exactly singular, then the routine +*> returns with INFO = i. Otherwise, the factored form of A is used +*> to estimate the condition number of the matrix A. If the +*> reciprocal of the condition number is less than machine precision, +*> INFO = N+1 is returned as a warning, but the routine still goes on +*> to solve for X and compute error bounds as described below. +*> +*> 3. The system of equations is solved for X using the factored form +*> of A. +*> +*> 4. Iterative refinement is applied to improve the computed solution +*> matrix and calculate error bounds and backward error estimates +*> for it. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> Specifies whether or not the factored form of A has been +*> supplied on entry. +*> = 'F': On entry, AF and IPIV contain the factored form of +*> A. AF and IPIV will not be modified. +*> = 'N': The matrix A will be copied to AF and factored. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> If FACT = 'F', then AF is an input argument and on entry +*> contains the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L from the factorization +*> A = U*D*U**T or A = L*D*L**T as computed by DSYTRF. +*> +*> If FACT = 'N', then AF is an output argument and on exit +*> returns the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L from the factorization +*> A = U*D*U**T or A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> If FACT = 'F', then IPIV is an input argument and on entry +*> contains details of the interchanges and the block structure +*> of D, as determined by DSYTRF. +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and +*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) +*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = +*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were +*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> +*> If FACT = 'N', then IPIV is an output argument and on exit +*> contains details of the interchanges and the block structure +*> of D, as determined by DSYTRF. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The N-by-NRHS right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The estimate of the reciprocal condition number of the matrix +*> A. If RCOND is less than the machine precision (in +*> particular, if RCOND = 0), the matrix is singular to working +*> precision. This condition is indicated by a return code of +*> INFO > 0. +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= max(1,3*N), and for best +*> performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where +*> NB is the optimal blocksize for DSYTRF. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, and i is +*> <= N: D(i,i) is exactly zero. The factorization +*> has been completed but the factor D is exactly +*> singular, so the solution and error bounds could +*> not be computed. RCOND = 0 is returned. +*> = N+1: D is nonsingular, but RCOND is less than machine +*> precision, meaning that the matrix is singular +*> to working precision. Nevertheless, the +*> solution and error bounds are computed because +*> there are a number of situations where the +*> computed solution can be more accurate than the +*> value of RCOND would suggest. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleSYsolve +* +* ===================================================================== + SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, + $ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, + $ IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER FACT, UPLO + INTEGER INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, NOFACT + INTEGER LWKOPT, NB + DOUBLE PRECISION ANORM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DSYCON, DSYRFS, DSYTRF, DSYTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) + $ THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LWORK.LT.MAX( 1, 3*N ) .AND. .NOT.LQUERY ) THEN + INFO = -18 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = MAX( 1, 3*N ) + IF( NOFACT ) THEN + NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( LWKOPT, N*NB ) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYSVX', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + IF( NOFACT ) THEN +* +* Compute the factorization A = U*D*U**T or A = L*D*L**T. +* + CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF ) + CALL DSYTRF( UPLO, N, AF, LDAF, IPIV, WORK, LWORK, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 )THEN + RCOND = ZERO + RETURN + END IF + END IF +* +* Compute the norm of the matrix A. +* + ANORM = DLANSY( 'I', UPLO, N, A, LDA, WORK ) +* +* Compute the reciprocal of the condition number of A. +* + CALL DSYCON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, IWORK, + $ INFO ) +* +* Compute the solution vectors X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solutions and +* compute error bounds and backward error estimates for them. +* + CALL DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, + $ LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* Set INFO = N+1 if the matrix is singular to working precision. +* + IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) + $ INFO = N + 1 +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYSVX +* + END diff --git a/math/lapack/src/main/fortran/dsysvxx.f b/math/lapack/src/main/fortran/dsysvxx.f new file mode 100644 index 0000000000..6e167d81e1 --- /dev/null +++ b/math/lapack/src/main/fortran/dsysvxx.f @@ -0,0 +1,696 @@ +*> \brief \b DSYSVXX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYSVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, +* EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, +* N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, +* NPARAMS, PARAMS, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER EQUED, FACT, UPLO +* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, +* $ N_ERR_BNDS +* DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), +* $ X( LDX, * ), WORK( * ) +* DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), +* $ ERR_BNDS_NORM( NRHS, * ), +* $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYSVXX uses the diagonal pivoting factorization to compute the +*> solution to a double precision system of linear equations A * X = B, where A +*> is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices. +*> +*> If requested, both normwise and maximum componentwise error bounds +*> are returned. DSYSVXX will return a solution with a tiny +*> guaranteed error (O(eps) where eps is the working machine +*> precision) unless the matrix is very ill-conditioned, in which +*> case a warning is returned. Relevant condition numbers also are +*> calculated and returned. +*> +*> DSYSVXX accepts user-provided factorizations and equilibration +*> factors; see the definitions of the FACT and EQUED options. +*> Solving with refinement and using a factorization from a previous +*> DSYSVXX call will also produce a solution with either O(eps) +*> errors or warnings, but we cannot make that claim for general +*> user-provided factorizations and equilibration factors if they +*> differ from what DSYSVXX would itself produce. +*> \endverbatim +* +*> \par Description: +* ================= +*> +*> \verbatim +*> +*> The following steps are performed: +*> +*> 1. If FACT = 'E', double precision scaling factors are computed to equilibrate +*> the system: +*> +*> diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B +*> +*> Whether or not the system will be equilibrated depends on the +*> scaling of the matrix A, but if equilibration is used, A is +*> overwritten by diag(S)*A*diag(S) and B by diag(S)*B. +*> +*> 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +*> the matrix A (after equilibration if FACT = 'E') as +*> +*> A = U * D * U**T, if UPLO = 'U', or +*> A = L * D * L**T, if UPLO = 'L', +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is symmetric and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. +*> +*> 3. If some D(i,i)=0, so that D is exactly singular, then the +*> routine returns with INFO = i. Otherwise, the factored form of A +*> is used to estimate the condition number of the matrix A (see +*> argument RCOND). If the reciprocal of the condition number is +*> less than machine precision, the routine still goes on to solve +*> for X and compute error bounds as described below. +*> +*> 4. The system of equations is solved for X using the factored form +*> of A. +*> +*> 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +*> the routine will use iterative refinement to try to get a small +*> error and error bounds. Refinement calculates the residual to at +*> least twice the working precision. +*> +*> 6. If equilibration was used, the matrix X is premultiplied by +*> diag(R) so that it solves the original system before +*> equilibration. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> Some optional parameters are bundled in the PARAMS array. These +*> settings determine how refinement is performed, but often the +*> defaults are acceptable. If the defaults are acceptable, users +*> can pass NPARAMS = 0 which prevents the source code from accessing +*> the PARAMS argument. +*> \endverbatim +*> +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> Specifies whether or not the factored form of the matrix A is +*> supplied on entry, and if not, whether the matrix A should be +*> equilibrated before it is factored. +*> = 'F': On entry, AF and IPIV contain the factored form of A. +*> If EQUED is not 'N', the matrix A has been +*> equilibrated with scaling factors given by S. +*> A, AF, and IPIV are not modified. +*> = 'N': The matrix A will be copied to AF and factored. +*> = 'E': The matrix A will be equilibrated if necessary, then +*> copied to AF and factored. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The symmetric matrix A. If UPLO = 'U', the leading N-by-N +*> upper triangular part of A contains the upper triangular +*> part of the matrix A, and the strictly lower triangular +*> part of A is not referenced. If UPLO = 'L', the leading +*> N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by +*> diag(S)*A*diag(S). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] AF +*> \verbatim +*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> If FACT = 'F', then AF is an input argument and on entry +*> contains the block diagonal matrix D and the multipliers +*> used to obtain the factor U or L from the factorization A = +*> U*D*U**T or A = L*D*L**T as computed by DSYTRF. +*> +*> If FACT = 'N', then AF is an output argument and on exit +*> returns the block diagonal matrix D and the multipliers +*> used to obtain the factor U or L from the factorization A = +*> U*D*U**T or A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] LDAF +*> \verbatim +*> LDAF is INTEGER +*> The leading dimension of the array AF. LDAF >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> If FACT = 'F', then IPIV is an input argument and on entry +*> contains details of the interchanges and the block +*> structure of D, as determined by DSYTRF. If IPIV(k) > 0, +*> then rows and columns k and IPIV(k) were interchanged and +*> D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and +*> IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and +*> -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 +*> diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, +*> then rows and columns k+1 and -IPIV(k) were interchanged +*> and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> +*> If FACT = 'N', then IPIV is an output argument and on exit +*> contains details of the interchanges and the block +*> structure of D, as determined by DSYTRF. +*> \endverbatim +*> +*> \param[in,out] EQUED +*> \verbatim +*> EQUED is CHARACTER*1 +*> Specifies the form of equilibration that was done. +*> = 'N': No equilibration (always true if FACT = 'N'). +*> = 'Y': Both row and column equilibration, i.e., A has been +*> replaced by diag(S) * A * diag(S). +*> EQUED is an input argument if FACT = 'F'; otherwise, it is an +*> output argument. +*> \endverbatim +*> +*> \param[in,out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (N) +*> The scale factors for A. If EQUED = 'Y', A is multiplied on +*> the left and right by diag(S). S is an input argument if FACT = +*> 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +*> = 'Y', each element of S must be positive. If S is output, each +*> element of S is a power of the radix. If S is input, each element +*> of S should be a power of the radix to ensure a reliable solution +*> and error estimates. Scaling by powers of the radix does not cause +*> rounding errors unless the result underflows or overflows. +*> Rounding errors during scaling lead to refining with a matrix that +*> is not equivalent to the input matrix, producing error estimates +*> that may not be reliable. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, +*> if EQUED = 'N', B is not modified; +*> if EQUED = 'Y', B is overwritten by diag(S)*B; +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> If INFO = 0, the N-by-NRHS solution matrix X to the original +*> system of equations. Note that A and B are modified on exit if +*> EQUED .ne. 'N', and the solution to the equilibrated system is +*> inv(diag(S))*X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> Reciprocal scaled condition number. This is an estimate of the +*> reciprocal Skeel condition number of the matrix A after +*> equilibration (if done). If this is less than the machine +*> precision (in particular, if it is zero), the matrix is singular +*> to working precision. Note that the error may still be small even +*> if this number is very small and the matrix appears ill- +*> conditioned. +*> \endverbatim +*> +*> \param[out] RPVGRW +*> \verbatim +*> RPVGRW is DOUBLE PRECISION +*> Reciprocal pivot growth. On exit, this contains the reciprocal +*> pivot growth factor norm(A)/norm(U). The "max absolute element" +*> norm is used. If this is much less than 1, then the stability of +*> the LU factorization of the (equilibrated) matrix A could be poor. +*> This also means that the solution X, estimated condition numbers, +*> and error bounds could be unreliable. If factorization fails with +*> 0 for the leading INFO columns of A. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is DOUBLE PRECISION array, dimension (NRHS) +*> Componentwise relative backward error. This is the +*> componentwise relative backward error of each solution vector X(j) +*> (i.e., the smallest relative change in any element of A or B that +*> makes X(j) an exact solution). +*> \endverbatim +*> +*> \param[in] N_ERR_BNDS +*> \verbatim +*> N_ERR_BNDS is INTEGER +*> Number of error bounds to return for each right hand side +*> and each type (normwise or componentwise). See ERR_BNDS_NORM and +*> ERR_BNDS_COMP below. +*> \endverbatim +*> +*> \param[out] ERR_BNDS_NORM +*> \verbatim +*> ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> normwise relative error, which is defined as follows: +*> +*> Normwise relative error in the ith solution vector: +*> max_j (abs(XTRUE(j,i) - X(j,i))) +*> ------------------------------ +*> max_j abs(X(j,i)) +*> +*> The array is indexed by the type of error information as described +*> below. There currently are up to three pieces of information +*> returned. +*> +*> The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_NORM(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * dlamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * dlamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated normwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * dlamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*A, where S scales each row by a power of the +*> radix so all absolute row sums of Z are approximately 1. +*> +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[out] ERR_BNDS_COMP +*> \verbatim +*> ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +*> For each right-hand side, this array contains information about +*> various error bounds and condition numbers corresponding to the +*> componentwise relative error, which is defined as follows: +*> +*> Componentwise relative error in the ith solution vector: +*> abs(XTRUE(j,i) - X(j,i)) +*> max_j ---------------------- +*> abs(X(j,i)) +*> +*> The array is indexed by the right-hand side i (on which the +*> componentwise relative error depends), and the type of error +*> information as described below. There currently are up to three +*> pieces of information returned for each right-hand side. If +*> componentwise accuracy is not requested (PARAMS(3) = 0.0), then +*> ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +*> the first (:,N_ERR_BNDS) entries are returned. +*> +*> The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +*> right-hand side. +*> +*> The second index in ERR_BNDS_COMP(:,err) contains the following +*> three fields: +*> err = 1 "Trust/don't trust" boolean. Trust the answer if the +*> reciprocal condition number is less than the threshold +*> sqrt(n) * dlamch('Epsilon'). +*> +*> err = 2 "Guaranteed" error bound: The estimated forward error, +*> almost certainly within a factor of 10 of the true error +*> so long as the next entry is greater than the threshold +*> sqrt(n) * dlamch('Epsilon'). This error bound should only +*> be trusted if the previous boolean is true. +*> +*> err = 3 Reciprocal condition number: Estimated componentwise +*> reciprocal condition number. Compared with the threshold +*> sqrt(n) * dlamch('Epsilon') to determine if the error +*> estimate is "guaranteed". These reciprocal condition +*> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +*> appropriately scaled matrix Z. +*> Let Z = S*(A*diag(x)), where x is the solution for the +*> current right-hand side and S scales each row of +*> A*diag(x) by a power of the radix so all absolute row +*> sums of Z are approximately 1. +*> +*> See Lapack Working Note 165 for further details and extra +*> cautions. +*> \endverbatim +*> +*> \param[in] NPARAMS +*> \verbatim +*> NPARAMS is INTEGER +*> Specifies the number of parameters set in PARAMS. If .LE. 0, the +*> PARAMS array is never referenced and default values are used. +*> \endverbatim +*> +*> \param[in,out] PARAMS +*> \verbatim +*> PARAMS is DOUBLE PRECISION array, dimension (NPARAMS) +*> Specifies algorithm parameters. If an entry is .LT. 0.0, then +*> that entry will be filled with default value used for that +*> parameter. Only positions up to NPARAMS are accessed; defaults +*> are used for higher-numbered parameters. +*> +*> PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +*> refinement or not. +*> Default: 1.0D+0 +*> = 0.0 : No refinement is performed, and no error bounds are +*> computed. +*> = 1.0 : Use the extra-precise refinement algorithm. +*> (other values are reserved for future use) +*> +*> PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +*> computations allowed for refinement. +*> Default: 10 +*> Aggressive: Set to 100 to permit convergence using approximate +*> factorizations or factorizations other than LU. If +*> the factorization uses a technique other than +*> Gaussian elimination, the guarantees in +*> err_bnds_norm and err_bnds_comp may no longer be +*> trustworthy. +*> +*> PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +*> will attempt to find a solution with small componentwise +*> relative error in the double-precision algorithm. Positive +*> is true, 0.0 is false. +*> Default: 1.0 (attempt componentwise convergence) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: Successful exit. The solution to every right-hand side is +*> guaranteed. +*> < 0: If INFO = -i, the i-th argument had an illegal value +*> > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +*> has been completed, but the factor U is exactly singular, so +*> the solution and error bounds could not be computed. RCOND = 0 +*> is returned. +*> = N+J: The solution corresponding to the Jth right-hand side is +*> not guaranteed. The solutions corresponding to other right- +*> hand sides K with K > J may not be guaranteed as well, but +*> only the first such right-hand side is reported. If a small +*> componentwise error is not requested (PARAMS(3) = 0.0) then +*> the Jth right-hand side is the first with a normwise error +*> bound that is not guaranteed (the smallest J such +*> that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +*> the Jth right-hand side is the first with either a normwise or +*> componentwise error bound that is not guaranteed (the smallest +*> J such that either ERR_BNDS_NORM(J,1) = 0.0 or +*> ERR_BNDS_COMP(J,1) = 0.0). See the definition of +*> ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +*> about all of the right-hand sides check ERR_BNDS_NORM or +*> ERR_BNDS_COMP. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYsolve +* +* ===================================================================== + SUBROUTINE DSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ NPARAMS, PARAMS, WORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, UPLO + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, RCEQU + INTEGER INFEQU, J + DOUBLE PRECISION AMAX, BIGNUM, SMIN, SMAX, SCOND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, DLAMCH, DLA_SYRPVGRW + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLA_SYRPVGRW +* .. +* .. External Subroutines .. + EXTERNAL DSYEQUB, DSYTRF, DSYTRS, + $ DLACPY, DLAQSY, XERBLA, DLASCL2, DSYRFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + RCEQU = .FALSE. + ELSE + RCEQU = LSAME( EQUED, 'Y' ) + ENDIF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in DSYRFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until DSYRFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME(UPLO, 'U') .AND. + $ .NOT.LSAME(UPLO, 'L') ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -10 + ELSE + IF ( RCEQU ) THEN + SMIN = BIGNUM + SMAX = ZERO + DO 10 J = 1, N + SMIN = MIN( SMIN, S( J ) ) + SMAX = MAX( SMAX, S( J ) ) + 10 CONTINUE + IF( SMIN.LE.ZERO ) THEN + INFO = -11 + ELSE IF( N.GT.0 ) THEN + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + ELSE + SCOND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -15 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYSVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) + RCEQU = LSAME( EQUED, 'Y' ) + END IF + END IF +* +* Scale the right-hand side. +* + IF( RCEQU ) CALL DLASCL2( N, NRHS, S, B, LDB ) +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LDL^T or UDU^T factorization of A. +* + CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF ) + CALL DSYTRF( UPLO, N, AF, LDAF, IPIV, WORK, 5*MAX(1,N), INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + IF ( N.GT.0 ) + $ RPVGRW = DLA_SYRPVGRW(UPLO, N, INFO, A, LDA, AF, + $ LDAF, IPIV, WORK ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + IF ( N.GT.0 ) + $ RPVGRW = DLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, + $ IPIV, WORK ) +* +* Compute the solution matrix X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL DSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO ) +* +* Scale solutions. +* + IF ( RCEQU ) THEN + CALL DLASCL2 ( N, NRHS, S, X, LDX ) + END IF +* + RETURN +* +* End of DSYSVXX +* + END diff --git a/math/lapack/src/main/fortran/dsyswapr.f b/math/lapack/src/main/fortran/dsyswapr.f new file mode 100644 index 0000000000..6e6c0f7e5c --- /dev/null +++ b/math/lapack/src/main/fortran/dsyswapr.f @@ -0,0 +1,193 @@ +*> \brief \b DSYSWAPR applies an elementary permutation on the rows and columns of a symmetric matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYSWAPR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYSWAPR( UPLO, N, A, LDA, I1, I2) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER I1, I2, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, N ) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYSWAPR applies an elementary permutation on the rows and the columns of +*> a symmetric matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the NB 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] I1 +*> \verbatim +*> I1 is INTEGER +*> Index of the first row to swap +*> \endverbatim +*> +*> \param[in] I2 +*> \verbatim +*> I2 is INTEGER +*> Index of the second row to swap +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYauxiliary +* +* ===================================================================== + SUBROUTINE DSYSWAPR( UPLO, N, A, LDA, I1, I2) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER I1, I2, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, N ) +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I + DOUBLE PRECISION TMP +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSWAP +* .. +* .. Executable Statements .. +* + UPPER = LSAME( UPLO, 'U' ) + IF (UPPER) THEN +* +* UPPER +* first swap +* - swap column I1 and I2 from I1 to I1-1 + CALL DSWAP( I1-1, A(1,I1), 1, A(1,I2), 1 ) +* +* second swap : +* - swap A(I1,I1) and A(I2,I2) +* - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 + TMP=A(I1,I1) + A(I1,I1)=A(I2,I2) + A(I2,I2)=TMP +* + DO I=1,I2-I1-1 + TMP=A(I1,I1+I) + A(I1,I1+I)=A(I1+I,I2) + A(I1+I,I2)=TMP + END DO +* +* third swap +* - swap row I1 and I2 from I2+1 to N + DO I=I2+1,N + TMP=A(I1,I) + A(I1,I)=A(I2,I) + A(I2,I)=TMP + END DO +* + ELSE +* +* LOWER +* first swap +* - swap row I1 and I2 from I1 to I1-1 + CALL DSWAP( I1-1, A(I1,1), LDA, A(I2,1), LDA ) +* +* second swap : +* - swap A(I1,I1) and A(I2,I2) +* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 + TMP=A(I1,I1) + A(I1,I1)=A(I2,I2) + A(I2,I2)=TMP +* + DO I=1,I2-I1-1 + TMP=A(I1+I,I1) + A(I1+I,I1)=A(I2,I1+I) + A(I2,I1+I)=TMP + END DO +* +* third swap +* - swap col I1 and I2 from I2+1 to N + DO I=I2+1,N + TMP=A(I,I1) + A(I,I1)=A(I,I2) + A(I,I2)=TMP + END DO +* + ENDIF + END SUBROUTINE DSYSWAPR + diff --git a/math/lapack/src/main/fortran/dsytd2.f b/math/lapack/src/main/fortran/dsytd2.f new file mode 100644 index 0000000000..6fb4d5507e --- /dev/null +++ b/math/lapack/src/main/fortran/dsytd2.f @@ -0,0 +1,323 @@ +*> \brief \b DSYTD2 reduces a symmetric matrix to real symmetric tridiagonal form by an orthogonal similarity transformation (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal +*> form T by an orthogonal similarity transformation: Q**T * A * Q = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of the tridiagonal matrix T: +*> D(i) = A(i,i). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is 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'. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-1) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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**T +*> +*> 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**T +*> +*> 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). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) +* .. +* +* ===================================================================== +* +* .. 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**T +* 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**T * 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**T - w * v**T +* + 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**T +* 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**T * 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**T - w * v**T +* + 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/math/lapack/src/main/fortran/dsytf2.f b/math/lapack/src/main/fortran/dsytf2.f new file mode 100644 index 0000000000..39ef4de7cc --- /dev/null +++ b/math/lapack/src/main/fortran/dsytf2.f @@ -0,0 +1,610 @@ +*> \brief \b DSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal pivoting method (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTF2 computes the factorization of a real symmetric matrix A 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, U**T 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> 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 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': +*> 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 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> > 0: if INFO = k, 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, 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**T, 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). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> 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 +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. 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**T 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. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IDAMAX( K-1, A( 1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN +* +* Column K is zero or underflow, 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)**T = A - W(k)*1/D(k)*W(k)**T +* + 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) )**T +* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**T +* + 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**T 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. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN +* +* Column K is zero or underflow, 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)**T = A - W(k)*(1/D(k))*W(k)**T +* + D11 = ONE / A( K, K ) + CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* Store L(k) in column K +* + CALL DSCAL( N-K, D11, A( K+1, K ), 1 ) + 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))**T +* +* 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/math/lapack/src/main/fortran/dsytf2_rk.f b/math/lapack/src/main/fortran/dsytf2_rk.f new file mode 100644 index 0000000000..45cf62ab9d --- /dev/null +++ b/math/lapack/src/main/fortran/dsytf2_rk.f @@ -0,0 +1,943 @@ +*> \brief \b DSYTF2_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTF2_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), E ( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DSYTF2_RK computes the factorization of a real symmetric matrix A +*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> For more information see Further Details section. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. For more info see Further +*> Details section. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> TODO: put further details +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> 01-01-96 - Based on modifications by +*> J. Lewis, Boeing Computer Services Company +*> A. Petitet, Computer Science Dept., +*> Univ. of Tenn., Knoxville abd , USA +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER, DONE + INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, + $ P, II + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, + $ ROWMAX, DTEMP, T, WK, WKM1, WKP1, SFMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IDAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, DSYR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTF2_RK', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = DLAMCH( 'S' ) +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* Initilize the first entry of array E, where superdiagonal +* elements of D are stored +* + E( 1 ) = ZERO +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2 +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 34 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IDAMAX( K-1, A( 1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K +* +* Set E( K ) to zero +* + IF( K.GT.1 ) + $ E( K ) = ZERO +* + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, +* use 1-by-1 pivot block +* + KP = K + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), + $ LDA ) + ROWMAX = ABS( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = IDAMAX( IMAX-1, A( 1, IMAX ), 1 ) + DTEMP = ABS( A( ITEMP, IMAX ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the leading +* submatrix A(1:k,1:k) if we have a 2-by-2 pivot +* + IF( P.GT.1 ) + $ CALL DSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 ) + IF( P.LT.(K-1) ) + $ CALL DSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ), + $ LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T +* +* Convert upper triangle of A into U form by applying +* the interchanges in columns k+1:N. +* + IF( K.LT.N ) + $ CALL DSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA ) +* + END IF +* +* Second swap +* + KK = K - KSTEP + 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the leading +* submatrix A(1:k,1:k) +* + IF( KP.GT.1 ) + $ CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) + IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) + $ CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K-1, K ) + A( K-1, K ) = A( KP, K ) + A( KP, K ) = T + END IF +* +* Convert upper triangle of A into U form by applying +* the interchanges in columns k+1:N. +* + IF( K.LT.N ) + $ CALL DSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), + $ LDA ) +* + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* + IF( K.GT.1 ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) and +* store U(k) in column k +* + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*1/D(k)*W(k)**T +* + D11 = ONE / A( K, K ) + CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) +* +* Store U(k) in column k +* + CALL DSCAL( K-1, D11, A( 1, K ), 1 ) + ELSE +* +* Store L(k) in column K +* + D11 = A( K, K ) + DO 16 II = 1, K - 1 + A( II, K ) = A( II, K ) / D11 + 16 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + END IF +* +* Store the superdiagonal element of D in array E +* + E( K ) = ZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k-1 now hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* Perform a rank-2 update of A(1:k-2,1:k-2) as +* +* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T +* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.GT.2 ) THEN +* + D12 = A( K-1, K ) + D22 = A( K-1, K-1 ) / D12 + D11 = A( K, K ) / D12 + T = ONE / ( D11*D22-ONE ) +* + DO 30 J = K - 2, 1, -1 +* + WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) + WK = T*( D22*A( J, K )-A( J, K-1 ) ) +* + DO 20 I = J, 1, -1 + A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - + $ ( A( I, K-1 ) / D12 )*WKM1 + 20 CONTINUE +* +* Store U(k) and U(k-1) in cols k and k-1 for row J +* + A( J, K ) = WK / D12 + A( J, K-1 ) = WKM1 / D12 +* + 30 CONTINUE +* + END IF +* +* Copy superdiagonal elements of D(K) to E(K) and +* ZERO out superdiagonal entry of A +* + E( K ) = A( K-1, K ) + E( K-1 ) = ZERO + A( K-1, K ) = ZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 34 CONTINUE +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* Initilize the unused last entry of the subdiagonal array E. +* + E( N ) = ZERO +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2 +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 64 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K +* +* Set E( K ) to zero +* + IF( K.LT.N ) + $ E( K ) = ZERO +* + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 42 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA ) + ROWMAX = ABS( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) + DTEMP = ABS( A( ITEMP, IMAX ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 42 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the trailing +* submatrix A(k:n,k:n) if we have a 2-by-2 pivot +* + IF( P.LT.N ) + $ CALL DSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) + IF( P.GT.(K+1) ) + $ CALL DSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T +* +* Convert lower triangle of A into L form by applying +* the interchanges in columns 1:k-1. +* + IF ( K.GT.1 ) + $ CALL DSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA ) +* + END IF +* +* Second swap +* + KK = K + KSTEP - 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the trailing +* submatrix A(k:n,k:n) +* + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) + $ CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K+1, K ) + A( K+1, K ) = A( KP, K ) + A( KP, K ) = T + END IF +* +* Convert lower triangle of A into L form by applying +* the interchanges in columns 1:k-1. +* + IF ( K.GT.1 ) + $ CALL DSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) +* + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) and +* store L(k) in column k +* + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* + D11 = ONE / A( K, K ) + CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* Store L(k) in column k +* + CALL DSCAL( N-K, D11, A( K+1, K ), 1 ) + ELSE +* +* Store L(k) in column k +* + D11 = A( K, K ) + DO 46 II = K + 1, N + A( II, K ) = A( II, K ) / D11 + 46 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) + END IF +* +* Store the subdiagonal element of D in array E +* + E( K ) = ZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* +* Perform a rank-2 update of A(k+2:n,k+2:n) as +* +* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T +* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.LT.N-1 ) THEN +* + D21 = A( K+1, K ) + D11 = A( K+1, K+1 ) / D21 + D22 = A( K, K ) / D21 + T = ONE / ( D11*D22-ONE ) +* + DO 60 J = K + 2, N +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WK = T*( D11*A( J, K )-A( J, K+1 ) ) + WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) +* +* Perform a rank-2 update of A(k+2:n,k+2:n) +* + DO 50 I = J, N + A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - + $ ( A( I, K+1 ) / D21 )*WKP1 + 50 CONTINUE +* +* Store L(k) and L(k+1) in cols k and k+1 for row J +* + A( J, K ) = WK / D21 + A( J, K+1 ) = WKP1 / D21 +* + 60 CONTINUE +* + END IF +* +* Copy subdiagonal elements of D(K) to E(K) and +* ZERO out subdiagonal entry of A +* + E( K ) = A( K+1, K ) + E( K+1 ) = ZERO + A( K+1, K ) = ZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 40 +* + 64 CONTINUE +* + END IF +* + RETURN +* +* End of DSYTF2_RK +* + END diff --git a/math/lapack/src/main/fortran/dsytf2_rook.f b/math/lapack/src/main/fortran/dsytf2_rook.f new file mode 100644 index 0000000000..237c9984c7 --- /dev/null +++ b/math/lapack/src/main/fortran/dsytf2_rook.f @@ -0,0 +1,813 @@ +*> \brief \b DSYTF2_ROOK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTF2_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTF2_ROOK computes the factorization of a real symmetric matrix A +*> using the bounded Bunch-Kaufman ("rook") 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, U**T 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> 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 IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> 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 IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> > 0: if INFO = k, 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, 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**T, 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). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> 01-01-96 - Based on modifications by +*> J. Lewis, Boeing Computer Services Company +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville abd , USA +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER, DONE + INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, + $ P, II + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, + $ ROWMAX, DTEMP, T, WK, WKM1, WKP1, SFMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IDAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, DSYR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTF2_ROOK', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = DLAMCH( 'S' ) +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* 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 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IDAMAX( K-1, A( 1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, +* use 1-by-1 pivot block +* + KP = K + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), + $ LDA ) + ROWMAX = ABS( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = IDAMAX( IMAX-1, A( 1, IMAX ), 1 ) + DTEMP = ABS( A( ITEMP, IMAX ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the leading +* submatrix A(1:k,1:k) if we have a 2-by-2 pivot +* + IF( P.GT.1 ) + $ CALL DSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 ) + IF( P.LT.(K-1) ) + $ CALL DSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ), + $ LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T + END IF +* +* Second swap +* + KK = K - KSTEP + 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the leading +* submatrix A(1:k,1:k) +* + IF( KP.GT.1 ) + $ CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) + IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) + $ CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K-1, K ) + A( K-1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* + IF( K.GT.1 ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) and +* store U(k) in column k +* + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*1/D(k)*W(k)**T +* + D11 = ONE / A( K, K ) + CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) +* +* Store U(k) in column k +* + CALL DSCAL( K-1, D11, A( 1, K ), 1 ) + ELSE +* +* Store L(k) in column K +* + D11 = A( K, K ) + DO 16 II = 1, K - 1 + A( II, K ) = A( II, K ) / D11 + 16 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k-1 now hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* Perform a rank-2 update of A(1:k-2,1:k-2) as +* +* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T +* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.GT.2 ) THEN +* + D12 = A( K-1, K ) + D22 = A( K-1, K-1 ) / D12 + D11 = A( K, K ) / D12 + T = ONE / ( D11*D22-ONE ) +* + DO 30 J = K - 2, 1, -1 +* + WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) + WK = T*( D22*A( J, K )-A( J, K-1 ) ) +* + DO 20 I = J, 1, -1 + A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - + $ ( A( I, K-1 ) / D12 )*WKM1 + 20 CONTINUE +* +* Store U(k) and U(k-1) in cols k and k-1 for row J +* + A( J, K ) = WK / D12 + A( J, K-1 ) = WKM1 / D12 +* + 30 CONTINUE +* + END IF +* + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2 +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 70 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 42 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA ) + ROWMAX = ABS( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) + DTEMP = ABS( A( ITEMP, IMAX ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 42 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the trailing +* submatrix A(k:n,k:n) if we have a 2-by-2 pivot +* + IF( P.LT.N ) + $ CALL DSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) + IF( P.GT.(K+1) ) + $ CALL DSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T + END IF +* +* Second swap +* + KK = K + KSTEP - 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the trailing +* submatrix A(k:n,k:n) +* + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) + $ CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K+1, K ) + A( K+1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) and +* store L(k) in column k +* + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* + D11 = ONE / A( K, K ) + CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* Store L(k) in column k +* + CALL DSCAL( N-K, D11, A( K+1, K ), 1 ) + ELSE +* +* Store L(k) in column k +* + D11 = A( K, K ) + DO 46 II = K + 1, N + A( II, K ) = A( II, K ) / D11 + 46 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* +* Perform a rank-2 update of A(k+2:n,k+2:n) as +* +* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T +* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.LT.N-1 ) THEN +* + D21 = A( K+1, K ) + D11 = A( K+1, K+1 ) / D21 + D22 = A( K, K ) / D21 + T = ONE / ( D11*D22-ONE ) +* + DO 60 J = K + 2, N +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WK = T*( D11*A( J, K )-A( J, K+1 ) ) + WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) +* +* Perform a rank-2 update of A(k+2:n,k+2:n) +* + DO 50 I = J, N + A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - + $ ( A( I, K+1 ) / D21 )*WKP1 + 50 CONTINUE +* +* Store L(k) and L(k+1) in cols k and k+1 for row J +* + A( J, K ) = WK / D21 + A( J, K+1 ) = WKP1 / D21 +* + 60 CONTINUE +* + END IF +* + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 40 +* + END IF +* + 70 CONTINUE +* + RETURN +* +* End of DSYTF2_ROOK +* + END diff --git a/math/lapack/src/main/fortran/dsytrd.f b/math/lapack/src/main/fortran/dsytrd.f new file mode 100644 index 0000000000..d330b241fa --- /dev/null +++ b/math/lapack/src/main/fortran/dsytrd.f @@ -0,0 +1,376 @@ +*> \brief \b DSYTRD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRD reduces a real symmetric matrix A to real symmetric +*> tridiagonal form T by an orthogonal similarity transformation: +*> Q**T * A * Q = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of the tridiagonal matrix T: +*> D(i) = A(i,i). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is 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'. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-1) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 1. +*> 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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**T +*> +*> 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**T +*> +*> 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). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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**T - W*V**T +* + 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**T - W*V**T +* + 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/math/lapack/src/main/fortran/dsytrd_2stage.f b/math/lapack/src/main/fortran/dsytrd_2stage.f new file mode 100644 index 0000000000..9997ecd253 --- /dev/null +++ b/math/lapack/src/main/fortran/dsytrd_2stage.f @@ -0,0 +1,337 @@ +*> \brief \b DSYTRD_2STAGE +* +* @generated from zhetrd_2stage.f, fortran z -> d, Sun Nov 6 19:34:06 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRD_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRD_2STAGE( VECT, UPLO, N, A, LDA, D, E, TAU, +* HOUS2, LHOUS2, WORK, LWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER VECT, UPLO +* INTEGER N, LDA, LWORK, LHOUS2, INFO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ) +* DOUBLE PRECISION A( LDA, * ), TAU( * ), +* HOUS2( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRD_2STAGE reduces a real symmetric matrix A to real symmetric +*> tridiagonal form T by a orthogonal similarity transformation: +*> Q1**T Q2**T* A * Q2 * Q1 = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] VECT +*> \verbatim +*> VECT is CHARACTER*1 +*> = 'N': No need for the Housholder representation, +*> in particular for the second stage (Band to +*> tridiagonal) and thus LHOUS2 is of size max(1, 4*N); +*> = 'V': the Householder representation is needed to +*> either generate Q1 Q2 or to apply Q1 Q2, +*> then LHOUS2 is to be queried and computed. +*> (NOT AVAILABLE IN THIS RELEASE). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, 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 band superdiagonal +*> of A are overwritten by the corresponding elements of the +*> internal band-diagonal matrix AB, and the elements above +*> the KD superdiagonal, with the array TAU, represent the orthogonal +*> matrix Q1 as a product of elementary reflectors; if UPLO +*> = 'L', the diagonal and band subdiagonal of A are over- +*> written by the corresponding elements of the internal band-diagonal +*> matrix AB, and the elements below the KD subdiagonal, with +*> the array TAU, represent the orthogonal matrix Q1 as a product +*> of elementary reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The off-diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-KD) +*> The scalar factors of the elementary reflectors of +*> the first stage (see Further Details). +*> \endverbatim +*> +*> \param[out] HOUS2 +*> \verbatim +*> HOUS2 is DOUBLE PRECISION array, dimension LHOUS2, that +*> store the Householder representation of the stage2 +*> band to tridiagonal. +*> \endverbatim +*> +*> \param[in] LHOUS2 +*> \verbatim +*> LHOUS2 is INTEGER +*> The dimension of the array HOUS2. LHOUS2 = MAX(1, dimension) +*> If LWORK = -1, or LHOUS2=-1, +*> then a query is assumed; the routine +*> only calculates the optimal size of the HOUS2 array, returns +*> this value as the first entry of the HOUS2 array, and no error +*> message related to LHOUS2 is issued by XERBLA. +*> LHOUS2 = MAX(1, dimension) where +*> dimension = 4*N if VECT='N' +*> not available now if VECT='H' +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK = MAX(1, dimension) +*> If LWORK = -1, or LHOUS2=-1, +*> then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSYTRD_2STAGE( VECT, UPLO, N, A, LDA, D, E, TAU, + $ HOUS2, LHOUS2, WORK, LWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER VECT, UPLO + INTEGER N, LDA, LWORK, LHOUS2, INFO +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), + $ HOUS2( * ), WORK( * ) +* .. +* +* ===================================================================== +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER, WANTQ + INTEGER KD, IB, LWMIN, LHMIN, LWRK, LDAB, WPOS, ABPOS +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSYTRD_SY2SB, DSYTRD_SB2ST +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + WANTQ = LSAME( VECT, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) .OR. ( LHOUS2.EQ.-1 ) +* +* Determine the block size, the workspace size and the hous size. +* + KD = ILAENV( 17, 'DSYTRD_2STAGE', VECT, N, -1, -1, -1 ) + IB = ILAENV( 18, 'DSYTRD_2STAGE', VECT, N, KD, -1, -1 ) + LHMIN = ILAENV( 19, 'DSYTRD_2STAGE', VECT, N, KD, IB, -1 ) + LWMIN = ILAENV( 20, 'DSYTRD_2STAGE', VECT, N, KD, IB, -1 ) +* WRITE(*,*),'DSYTRD_2STAGE N KD UPLO LHMIN LWMIN ',N, KD, UPLO, +* $ LHMIN, LWMIN +* + IF( .NOT.LSAME( VECT, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LHOUS2.LT.LHMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN + HOUS2( 1 ) = LHMIN + WORK( 1 ) = LWMIN + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRD_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine pointer position +* + LDAB = KD+1 + LWRK = LWORK-LDAB*N + ABPOS = 1 + WPOS = ABPOS + LDAB*N + CALL DSYTRD_SY2SB( UPLO, N, KD, A, LDA, WORK( ABPOS ), LDAB, + $ TAU, WORK( WPOS ), LWRK, INFO ) + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRD_SY2SB', -INFO ) + RETURN + END IF + CALL DSYTRD_SB2ST( 'Y', VECT, UPLO, N, KD, + $ WORK( ABPOS ), LDAB, D, E, + $ HOUS2, LHOUS2, WORK( WPOS ), LWRK, INFO ) + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRD_SB2ST', -INFO ) + RETURN + END IF +* +* + HOUS2( 1 ) = LHMIN + WORK( 1 ) = LWMIN + RETURN +* +* End of DSYTRD_2STAGE +* + END diff --git a/math/lapack/src/main/fortran/dsytrd_sb2st.F b/math/lapack/src/main/fortran/dsytrd_sb2st.F new file mode 100644 index 0000000000..59ef01381d --- /dev/null +++ b/math/lapack/src/main/fortran/dsytrd_sb2st.F @@ -0,0 +1,556 @@ +*> \brief \b DSYTRD_SB2ST reduces a real symmetric band matrix A to real symmetric tridiagonal form T +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRD_SB2ST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRD_SB2ST( STAGE1, VECT, UPLO, N, KD, AB, LDAB, +* D, E, HOUS, LHOUS, WORK, LWORK, INFO ) +* +* #if defined(_OPENMP) +* use omp_lib +* #endif +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER STAGE1, UPLO, VECT +* INTEGER N, KD, IB, LDAB, LHOUS, LWORK, INFO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ) +* DOUBLE PRECISION AB( LDAB, * ), HOUS( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRD_SB2ST reduces a real symmetric band matrix A to real symmetric +*> tridiagonal form T by a orthogonal similarity transformation: +*> Q**T * A * Q = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] STAGE +*> \verbatim +*> STAGE is CHARACTER*1 +*> = 'N': "No": to mention that the stage 1 of the reduction +*> from dense to band using the dsytrd_sy2sb routine +*> was not called before this routine to reproduce AB. +*> In other term this routine is called as standalone. +*> = 'Y': "Yes": to mention that the stage 1 of the +*> reduction from dense to band using the dsytrd_sy2sb +*> routine has been called to produce AB (e.g., AB is +*> the output of dsytrd_sy2sb. +*> \endverbatim +*> +*> \param[in] VECT +*> \verbatim +*> VECT is CHARACTER*1 +*> = 'N': No need for the Housholder representation, +*> and thus LHOUS is of size max(1, 4*N); +*> = 'V': the Householder representation is needed to +*> either generate or to apply Q later on, +*> then LHOUS is to be queried and computed. +*> (NOT AVAILABLE IN THIS RELEASE). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> On exit, the diagonal elements of AB are overwritten by the +*> diagonal elements of the tridiagonal matrix T; if KD > 0, the +*> elements on the first superdiagonal (if UPLO = 'U') or the +*> first subdiagonal (if UPLO = 'L') are overwritten by the +*> off-diagonal elements of T; the rest of AB is overwritten by +*> values generated during the reduction. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The off-diagonal elements of the tridiagonal matrix T: +*> E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. +*> \endverbatim +*> +*> \param[out] HOUS +*> \verbatim +*> HOUS is DOUBLE PRECISION array, dimension LHOUS, that +*> store the Householder representation. +*> \endverbatim +*> +*> \param[in] LHOUS +*> \verbatim +*> LHOUS is INTEGER +*> The dimension of the array HOUS. LHOUS = MAX(1, dimension) +*> If LWORK = -1, or LHOUS=-1, +*> then a query is assumed; the routine +*> only calculates the optimal size of the HOUS array, returns +*> this value as the first entry of the HOUS array, and no error +*> message related to LHOUS is issued by XERBLA. +*> LHOUS = MAX(1, dimension) where +*> dimension = 4*N if VECT='N' +*> not available now if VECT='H' +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK = MAX(1, dimension) +*> If LWORK = -1, or LHOUS=-1, +*> then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup real16OTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSYTRD_SB2ST( STAGE1, VECT, UPLO, N, KD, AB, LDAB, + $ D, E, HOUS, LHOUS, WORK, LWORK, INFO ) +* +#if defined(_OPENMP) + use omp_lib +#endif +* + IMPLICIT NONE +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER STAGE1, UPLO, VECT + INTEGER N, KD, LDAB, LHOUS, LWORK, INFO +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) + DOUBLE PRECISION AB( LDAB, * ), HOUS( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION RZERO + DOUBLE PRECISION ZERO, ONE + PARAMETER ( RZERO = 0.0D+0, + $ ZERO = 0.0D+0, + $ ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, WANTQ, UPPER, AFTERS1 + INTEGER I, M, K, IB, SWEEPID, MYID, SHIFT, STT, ST, + $ ED, STIND, EDIND, BLKLASTIND, COLPT, THED, + $ STEPERCOL, GRSIZ, THGRSIZ, THGRNB, THGRID, + $ NBTILES, TTYPE, TID, NTHREADS, DEBUG, + $ ABDPOS, ABOFDPOS, DPOS, OFDPOS, AWPOS, + $ INDA, INDW, APOS, SIZEA, LDA, INDV, INDTAU, + $ SIDEV, SIZETAU, LDV, LHMIN, LWMIN +* .. +* .. External Subroutines .. + EXTERNAL DSB2ST_KERNELS, DLACPY, DLASET +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN, MAX, CEILING, REAL +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Determine the minimal workspace size required. +* Test the input parameters +* + DEBUG = 0 + INFO = 0 + AFTERS1 = LSAME( STAGE1, 'Y' ) + WANTQ = LSAME( VECT, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) .OR. ( LHOUS.EQ.-1 ) +* +* Determine the block size, the workspace size and the hous size. +* + IB = ILAENV( 18, 'DSYTRD_SB2ST', VECT, N, KD, -1, -1 ) + LHMIN = ILAENV( 19, 'DSYTRD_SB2ST', VECT, N, KD, IB, -1 ) + LWMIN = ILAENV( 20, 'DSYTRD_SB2ST', VECT, N, KD, IB, -1 ) +* + IF( .NOT.AFTERS1 .AND. .NOT.LSAME( STAGE1, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( VECT, 'N' ) ) THEN + INFO = -2 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( KD.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.(KD+1) ) THEN + INFO = -7 + ELSE IF( LHOUS.LT.LHMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + HOUS( 1 ) = LHMIN + WORK( 1 ) = LWMIN + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRD_SB2ST', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + HOUS( 1 ) = 1 + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine pointer position +* + LDV = KD + IB + SIZETAU = 2 * N + SIDEV = 2 * N + INDTAU = 1 + INDV = INDTAU + SIZETAU + LDA = 2 * KD + 1 + SIZEA = LDA * N + INDA = 1 + INDW = INDA + SIZEA + NTHREADS = 1 + TID = 0 +* + IF( UPPER ) THEN + APOS = INDA + KD + AWPOS = INDA + DPOS = APOS + KD + OFDPOS = DPOS - 1 + ABDPOS = KD + 1 + ABOFDPOS = KD + ELSE + APOS = INDA + AWPOS = INDA + KD + 1 + DPOS = APOS + OFDPOS = DPOS + 1 + ABDPOS = 1 + ABOFDPOS = 2 + + ENDIF +* +* Case KD=0: +* The matrix is diagonal. We just copy it (convert to "real" for +* real because D is double and the imaginary part should be 0) +* and store it in D. A sequential code here is better or +* in a parallel environment it might need two cores for D and E +* + IF( KD.EQ.0 ) THEN + DO 30 I = 1, N + D( I ) = ( AB( ABDPOS, I ) ) + 30 CONTINUE + DO 40 I = 1, N-1 + E( I ) = RZERO + 40 CONTINUE +* + HOUS( 1 ) = 1 + WORK( 1 ) = 1 + RETURN + END IF +* +* Case KD=1: +* The matrix is already Tridiagonal. We have to make diagonal +* and offdiagonal elements real, and store them in D and E. +* For that, for real precision just copy the diag and offdiag +* to D and E while for the COMPLEX case the bulge chasing is +* performed to convert the hermetian tridiagonal to symmetric +* tridiagonal. A simpler coversion formula might be used, but then +* updating the Q matrix will be required and based if Q is generated +* or not this might complicate the story. +* + IF( KD.EQ.1 ) THEN + DO 50 I = 1, N + D( I ) = ( AB( ABDPOS, I ) ) + 50 CONTINUE +* + IF( UPPER ) THEN + DO 60 I = 1, N-1 + E( I ) = ( AB( ABOFDPOS, I+1 ) ) + 60 CONTINUE + ELSE + DO 70 I = 1, N-1 + E( I ) = ( AB( ABOFDPOS, I ) ) + 70 CONTINUE + ENDIF +* + HOUS( 1 ) = 1 + WORK( 1 ) = 1 + RETURN + END IF +* +* Main code start here. +* Reduce the symmetric band of A to a tridiagonal matrix. +* + THGRSIZ = N + GRSIZ = 1 + SHIFT = 3 + NBTILES = CEILING( REAL(N)/REAL(KD) ) + STEPERCOL = CEILING( REAL(SHIFT)/REAL(GRSIZ) ) + THGRNB = CEILING( REAL(N-1)/REAL(THGRSIZ) ) +* + CALL DLACPY( "A", KD+1, N, AB, LDAB, WORK( APOS ), LDA ) + CALL DLASET( "A", KD, N, ZERO, ZERO, WORK( AWPOS ), LDA ) +* +* +* openMP parallelisation start here +* +#if defined(_OPENMP) +!$OMP PARALLEL PRIVATE( TID, THGRID, BLKLASTIND ) +!$OMP$ PRIVATE( THED, I, M, K, ST, ED, STT, SWEEPID ) +!$OMP$ PRIVATE( MYID, TTYPE, COLPT, STIND, EDIND ) +!$OMP$ SHARED ( UPLO, WANTQ, INDV, INDTAU, HOUS, WORK) +!$OMP$ SHARED ( N, KD, IB, NBTILES, LDA, LDV, INDA ) +!$OMP$ SHARED ( STEPERCOL, THGRNB, THGRSIZ, GRSIZ, SHIFT ) +!$OMP MASTER +#endif +* +* main bulge chasing loop +* + DO 100 THGRID = 1, THGRNB + STT = (THGRID-1)*THGRSIZ+1 + THED = MIN( (STT + THGRSIZ -1), (N-1)) + DO 110 I = STT, N-1 + ED = MIN( I, THED ) + IF( STT.GT.ED ) EXIT + DO 120 M = 1, STEPERCOL + ST = STT + DO 130 SWEEPID = ST, ED + DO 140 K = 1, GRSIZ + MYID = (I-SWEEPID)*(STEPERCOL*GRSIZ) + $ + (M-1)*GRSIZ + K + IF ( MYID.EQ.1 ) THEN + TTYPE = 1 + ELSE + TTYPE = MOD( MYID, 2 ) + 2 + ENDIF + + IF( TTYPE.EQ.2 ) THEN + COLPT = (MYID/2)*KD + SWEEPID + STIND = COLPT-KD+1 + EDIND = MIN(COLPT,N) + BLKLASTIND = COLPT + ELSE + COLPT = ((MYID+1)/2)*KD + SWEEPID + STIND = COLPT-KD+1 + EDIND = MIN(COLPT,N) + IF( ( STIND.GE.EDIND-1 ).AND. + $ ( EDIND.EQ.N ) ) THEN + BLKLASTIND = N + ELSE + BLKLASTIND = 0 + ENDIF + ENDIF +* +* Call the kernel +* +#if defined(_OPENMP) + IF( TTYPE.NE.1 ) THEN +!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) +!$OMP$ DEPEND(in:WORK(MYID-1)) +!$OMP$ DEPEND(out:WORK(MYID)) + TID = OMP_GET_THREAD_NUM() + CALL DSB2ST_KERNELS( UPLO, WANTQ, TTYPE, + $ STIND, EDIND, SWEEPID, N, KD, IB, + $ WORK ( INDA ), LDA, + $ HOUS( INDV ), HOUS( INDTAU ), LDV, + $ WORK( INDW + TID*KD ) ) +!$OMP END TASK + ELSE +!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) +!$OMP$ DEPEND(out:WORK(MYID)) + TID = OMP_GET_THREAD_NUM() + CALL DSB2ST_KERNELS( UPLO, WANTQ, TTYPE, + $ STIND, EDIND, SWEEPID, N, KD, IB, + $ WORK ( INDA ), LDA, + $ HOUS( INDV ), HOUS( INDTAU ), LDV, + $ WORK( INDW + TID*KD ) ) +!$OMP END TASK + ENDIF +#else + CALL DSB2ST_KERNELS( UPLO, WANTQ, TTYPE, + $ STIND, EDIND, SWEEPID, N, KD, IB, + $ WORK ( INDA ), LDA, + $ HOUS( INDV ), HOUS( INDTAU ), LDV, + $ WORK( INDW + TID*KD ) ) +#endif + IF ( BLKLASTIND.GE.(N-1) ) THEN + STT = STT + 1 + EXIT + ENDIF + 140 CONTINUE + 130 CONTINUE + 120 CONTINUE + 110 CONTINUE + 100 CONTINUE +* +#if defined(_OPENMP) +!$OMP END MASTER +!$OMP END PARALLEL +#endif +* +* Copy the diagonal from A to D. Note that D is REAL thus only +* the Real part is needed, the imaginary part should be zero. +* + DO 150 I = 1, N + D( I ) = ( WORK( DPOS+(I-1)*LDA ) ) + 150 CONTINUE +* +* Copy the off diagonal from A to E. Note that E is REAL thus only +* the Real part is needed, the imaginary part should be zero. +* + IF( UPPER ) THEN + DO 160 I = 1, N-1 + E( I ) = ( WORK( OFDPOS+I*LDA ) ) + 160 CONTINUE + ELSE + DO 170 I = 1, N-1 + E( I ) = ( WORK( OFDPOS+(I-1)*LDA ) ) + 170 CONTINUE + ENDIF +* + HOUS( 1 ) = LHMIN + WORK( 1 ) = LWMIN + RETURN +* +* End of DSYTRD_SB2ST +* + END + diff --git a/math/lapack/src/main/fortran/dsytrd_sy2sb.f b/math/lapack/src/main/fortran/dsytrd_sy2sb.f new file mode 100644 index 0000000000..a0e028a302 --- /dev/null +++ b/math/lapack/src/main/fortran/dsytrd_sy2sb.f @@ -0,0 +1,517 @@ +*> \brief \b DSYTRD_SY2SB +* +* @generated from zhetrd_he2hb.f, fortran z -> d, Wed Dec 7 08:22:39 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRD_SY2SB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRD_SY2SB( UPLO, N, KD, A, LDA, AB, LDAB, TAU, +* WORK, LWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDAB, LWORK, N, KD +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), AB( LDAB, * ), +* TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRD_SY2SB reduces a real symmetric matrix A to real symmetric +*> band-diagonal form AB by a orthogonal similarity transformation: +*> Q**T * A * Q = AB. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the reduced matrix if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> The reduced matrix is stored in the array AB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, if 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On exit, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-KD) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension LWORK. +*> On exit, if INFO = 0, or if LWORK=-1, +*> WORK(1) returns the size of LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK which should be calculated +* by a workspace query. LWORK = MAX(1, LWORK_QUERY) +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> LWORK_QUERY = N*KD + N*max(KD,FACTOPTNB) + 2*KD*KD +*> where FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice otherwise +*> putting LWORK=-1 will provide the size of WORK. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +*> \verbatim +*> +*> If UPLO = 'U', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(k)**T . . . H(2)**T H(1)**T, where k = n-kd. +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i+kd-1) = 0 and v(i+kd) = 1; conjg(v(i+kd+1:n)) is stored on exit in +*> A(i,i+kd+1:n), 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(k), where k = n-kd. +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(kd+1:i) = 0 and v(i+kd+1) = 1; v(i+kd+2:n) is stored on exit in +* A(i+kd+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': +*> +*> ( ab ab/v1 v1 v1 v1 ) ( ab ) +*> ( ab ab/v2 v2 v2 ) ( ab/v1 ab ) +*> ( ab ab/v3 v3 ) ( v1 ab/v2 ab ) +*> ( ab ab/v4 ) ( v1 v2 ab/v3 ab ) +*> ( ab ) ( v1 v2 v3 ab/v4 ab ) +*> +*> where d and e denote diagonal and off-diagonal elements of T, and vi +*> denotes an element of the vector defining H(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSYTRD_SY2SB( UPLO, N, KD, A, LDA, AB, LDAB, TAU, + $ WORK, LWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDAB, LWORK, N, KD +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), AB( LDAB, * ), + $ TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION RONE + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( RONE = 1.0D+0, + $ ZERO = 0.0D+0, + $ ONE = 1.0D+0, + $ HALF = 0.5D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, J, IINFO, LWMIN, PN, PK, LK, + $ LDT, LDW, LDS2, LDS1, + $ LS2, LS1, LW, LT, + $ TPOS, WPOS, S2POS, S1POS +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSYR2K, DSYMM, DGEMM, + $ DLARFT, DGELQF, DGEQRF, DLASET +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN, MAX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Determine the minimal workspace size required +* and test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + LWMIN = ILAENV( 20, 'DSYTRD_SY2SB', '', N, KD, -1, -1 ) + + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KD.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDAB.LT.MAX( 1, KD+1 ) ) THEN + INFO = -7 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRD_SY2SB', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + WORK( 1 ) = LWMIN + RETURN + END IF +* +* Quick return if possible +* Copy the upper/lower portion of A into AB +* + IF( N.LE.KD+1 ) THEN + IF( UPPER ) THEN + DO 100 I = 1, N + LK = MIN( KD+1, I ) + CALL DCOPY( LK, A( I-LK+1, I ), 1, + $ AB( KD+1-LK+1, I ), 1 ) + 100 CONTINUE + ELSE + DO 110 I = 1, N + LK = MIN( KD+1, N-I+1 ) + CALL DCOPY( LK, A( I, I ), 1, AB( 1, I ), 1 ) + 110 CONTINUE + ENDIF + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine the pointer position for the workspace +* + LDT = KD + LDS1 = KD + LT = LDT*KD + LW = N*KD + LS1 = LDS1*KD + LS2 = LWMIN - LT - LW - LS1 +* LS2 = N*MAX(KD,FACTOPTNB) + TPOS = 1 + WPOS = TPOS + LT + S1POS = WPOS + LW + S2POS = S1POS + LS1 + IF( UPPER ) THEN + LDW = KD + LDS2 = KD + ELSE + LDW = N + LDS2 = N + ENDIF +* +* +* Set the workspace of the triangular matrix T to zero once such a +* way everytime T is generated the upper/lower portion will be always zero +* + CALL DLASET( "A", LDT, KD, ZERO, ZERO, WORK( TPOS ), LDT ) +* + IF( UPPER ) THEN + DO 10 I = 1, N - KD, KD + PN = N-I-KD+1 + PK = MIN( N-I-KD+1, KD ) +* +* Compute the LQ factorization of the current block +* + CALL DGELQF( KD, PN, A( I, I+KD ), LDA, + $ TAU( I ), WORK( S2POS ), LS2, IINFO ) +* +* Copy the upper portion of A into AB +* + DO 20 J = I, I+PK-1 + LK = MIN( KD, N-J ) + 1 + CALL DCOPY( LK, A( J, J ), LDA, AB( KD+1, J ), LDAB-1 ) + 20 CONTINUE +* + CALL DLASET( 'Lower', PK, PK, ZERO, ONE, + $ A( I, I+KD ), LDA ) +* +* Form the matrix T +* + CALL DLARFT( 'Forward', 'Rowwise', PN, PK, + $ A( I, I+KD ), LDA, TAU( I ), + $ WORK( TPOS ), LDT ) +* +* Compute W: +* + CALL DGEMM( 'Conjugate', 'No transpose', PK, PN, PK, + $ ONE, WORK( TPOS ), LDT, + $ A( I, I+KD ), LDA, + $ ZERO, WORK( S2POS ), LDS2 ) +* + CALL DSYMM( 'Right', UPLO, PK, PN, + $ ONE, A( I+KD, I+KD ), LDA, + $ WORK( S2POS ), LDS2, + $ ZERO, WORK( WPOS ), LDW ) +* + CALL DGEMM( 'No transpose', 'Conjugate', PK, PK, PN, + $ ONE, WORK( WPOS ), LDW, + $ WORK( S2POS ), LDS2, + $ ZERO, WORK( S1POS ), LDS1 ) +* + CALL DGEMM( 'No transpose', 'No transpose', PK, PN, PK, + $ -HALF, WORK( S1POS ), LDS1, + $ A( I, I+KD ), LDA, + $ ONE, WORK( WPOS ), LDW ) +* +* +* Update the unreduced submatrix A(i+kd:n,i+kd:n), using +* an update of the form: A := A - V'*W - W'*V +* + CALL DSYR2K( UPLO, 'Conjugate', PN, PK, + $ -ONE, A( I, I+KD ), LDA, + $ WORK( WPOS ), LDW, + $ RONE, A( I+KD, I+KD ), LDA ) + 10 CONTINUE +* +* Copy the upper band to AB which is the band storage matrix +* + DO 30 J = N-KD+1, N + LK = MIN(KD, N-J) + 1 + CALL DCOPY( LK, A( J, J ), LDA, AB( KD+1, J ), LDAB-1 ) + 30 CONTINUE +* + ELSE +* +* Reduce the lower triangle of A to lower band matrix +* + DO 40 I = 1, N - KD, KD + PN = N-I-KD+1 + PK = MIN( N-I-KD+1, KD ) +* +* Compute the QR factorization of the current block +* + CALL DGEQRF( PN, KD, A( I+KD, I ), LDA, + $ TAU( I ), WORK( S2POS ), LS2, IINFO ) +* +* Copy the upper portion of A into AB +* + DO 50 J = I, I+PK-1 + LK = MIN( KD, N-J ) + 1 + CALL DCOPY( LK, A( J, J ), 1, AB( 1, J ), 1 ) + 50 CONTINUE +* + CALL DLASET( 'Upper', PK, PK, ZERO, ONE, + $ A( I+KD, I ), LDA ) +* +* Form the matrix T +* + CALL DLARFT( 'Forward', 'Columnwise', PN, PK, + $ A( I+KD, I ), LDA, TAU( I ), + $ WORK( TPOS ), LDT ) +* +* Compute W: +* + CALL DGEMM( 'No transpose', 'No transpose', PN, PK, PK, + $ ONE, A( I+KD, I ), LDA, + $ WORK( TPOS ), LDT, + $ ZERO, WORK( S2POS ), LDS2 ) +* + CALL DSYMM( 'Left', UPLO, PN, PK, + $ ONE, A( I+KD, I+KD ), LDA, + $ WORK( S2POS ), LDS2, + $ ZERO, WORK( WPOS ), LDW ) +* + CALL DGEMM( 'Conjugate', 'No transpose', PK, PK, PN, + $ ONE, WORK( S2POS ), LDS2, + $ WORK( WPOS ), LDW, + $ ZERO, WORK( S1POS ), LDS1 ) +* + CALL DGEMM( 'No transpose', 'No transpose', PN, PK, PK, + $ -HALF, A( I+KD, I ), LDA, + $ WORK( S1POS ), LDS1, + $ ONE, WORK( WPOS ), LDW ) +* +* +* Update the unreduced submatrix A(i+kd:n,i+kd:n), using +* an update of the form: A := A - V*W' - W*V' +* + CALL DSYR2K( UPLO, 'No transpose', PN, PK, + $ -ONE, A( I+KD, I ), LDA, + $ WORK( WPOS ), LDW, + $ RONE, A( I+KD, I+KD ), LDA ) +* ================================================================== +* RESTORE A FOR COMPARISON AND CHECKING TO BE REMOVED +* DO 45 J = I, I+PK-1 +* LK = MIN( KD, N-J ) + 1 +* CALL DCOPY( LK, AB( 1, J ), 1, A( J, J ), 1 ) +* 45 CONTINUE +* ================================================================== + 40 CONTINUE +* +* Copy the lower band to AB which is the band storage matrix +* + DO 60 J = N-KD+1, N + LK = MIN(KD, N-J) + 1 + CALL DCOPY( LK, A( J, J ), 1, AB( 1, J ), 1 ) + 60 CONTINUE + + END IF +* + WORK( 1 ) = LWMIN + RETURN +* +* End of DSYTRD_SY2SB +* + END diff --git a/math/lapack/src/main/fortran/dsytrf.f b/math/lapack/src/main/fortran/dsytrf.f new file mode 100644 index 0000000000..d8da4f122a --- /dev/null +++ b/math/lapack/src/main/fortran/dsytrf.f @@ -0,0 +1,363 @@ +*> \brief \b DSYTRF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, 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). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is 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. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, 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**T, 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). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by DLASYF; +* 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**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by DLASYF; +* 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/math/lapack/src/main/fortran/dsytrf_aa.f b/math/lapack/src/main/fortran/dsytrf_aa.f new file mode 100644 index 0000000000..c3d598b28a --- /dev/null +++ b/math/lapack/src/main/fortran/dsytrf_aa.f @@ -0,0 +1,480 @@ +*> \brief \b DSYTRF_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRF_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRF_AA computes the factorization of a real symmetric matrix A +*> using the Aasen's algorithm. The form of the factorization is +*> +*> A = U*T*U**T or A = L*T*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is a symmetric tridiagonal matrix. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, 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 tridiagonal matrix is stored in the diagonals +*> and the subdiagonals of A just below (or above) the diagonals, +*> and L is stored below (or above) the subdiaonals, when UPLO +*> is 'L' (or 'U'). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= MAX(1,2*N). 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER J, LWKOPT, IINFO + INTEGER NB, MJ, NJ, K1, K2, J1, J2, J3, JB + DOUBLE PRECISION ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Determine the block size +* + NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 ) +* +* 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.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = (NB+1)*N + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRF_AA', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return +* + IF ( N.EQ.0 ) THEN + RETURN + ENDIF + IPIV( 1 ) = 1 + IF ( N.EQ.1 ) THEN + IF ( A( 1, 1 ).EQ.ZERO ) THEN + INFO = 1 + END IF + RETURN + END IF +* +* Adjubst block size based on the workspace size +* + IF( LWORK.LT.((1+NB)*N) ) THEN + NB = ( LWORK-N ) / N + END IF +* + IF( UPPER ) THEN +* +* ..................................................... +* Factorize A as L*D*L**T using the upper triangle of A +* ..................................................... +* +* Copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N)) +* + CALL DCOPY( N, A( 1, 1 ), LDA, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by DLASYF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 10 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J + 1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL DLASYF_AA( UPLO, 2-K1, N-J, JB, + $ A( MAX(1, J), J+1 ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), + $ IINFO ) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL DSWAP( J1-K1-2, A( 1, J2 ), 1, + $ A( 1, IPIV(J2) ), 1 ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and +* WORK stores the current block of the auxiriarly matrix H +* + IF( J.LT.N ) THEN +* +* If first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = A( J, J+1 ) + A( J, J+1 ) = ONE + CALL DCOPY( N-J, A( J-1, J+1 ), LDA, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL DSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, +* while K1=0 and K2=1 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with DGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL DGEMV( 'No transpose', MJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J1-K2, J3 ), 1, + $ ONE, A( J3, J3 ), LDA ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block of J2-th block row with DGEMM +* + CALL DGEMM( 'Transpose', 'Transpose', + $ NJ, N-J3+1, JB+1, + $ -ONE, A( J1-K2, J2 ), LDA, + $ WORK( J3-J1+1+K1*N ), N, + $ ONE, A( J2, J3 ), LDA ) + END DO +* +* Recover T( J, J+1 ) +* + A( J, J+1 ) = ALPHA + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL DCOPY( N-J, A( J+1, J+1 ), LDA, WORK( 1 ), 1 ) + END IF + GO TO 10 + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* +* copy first column A(1:N, 1) into H(1:N, 1) +* (stored in WORK(1:N)) +* + CALL DCOPY( N, A( 1, 1 ), 1, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by DLASYF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 11 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J+1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL DLASYF_AA( UPLO, 2-K1, N-J, JB, + $ A( J+1, MAX(1, J) ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), IINFO) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL DSWAP( J1-K1-2, A( J2, 1 ), LDA, + $ A( IPIV(J2), 1 ), LDA ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* A(J2+1, J1-1) stores L(J2+1, J1) and +* WORK(J2+1, 1) stores H(J2+1, 1) +* + IF( J.LT.N ) THEN +* +* if first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = A( J+1, J ) + A( J+1, J ) = ONE + CALL DCOPY( N-J, A( J+1, J-1 ), 1, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL DSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, +* while K1=0 and K2=1 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with DGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL DGEMV( 'No transpose', MJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J3, J1-K2 ), LDA, + $ ONE, A( J3, J3 ), 1 ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block in J2-th block column with DGEMM +* + CALL DGEMM( 'No transpose', 'Transpose', + $ N-J3+1, NJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J2, J1-K2 ), LDA, + $ ONE, A( J3, J2 ), LDA ) + END DO +* +* Recover T( J+1, J ) +* + A( J+1, J ) = ALPHA + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL DCOPY( N-J, A( J+1, J+1 ), 1, WORK( 1 ), 1 ) + END IF + GO TO 11 + END IF +* + 20 CONTINUE + RETURN +* +* End of DSYTRF_AA +* + END diff --git a/math/lapack/src/main/fortran/dsytrf_rk.f b/math/lapack/src/main/fortran/dsytrf_rk.f new file mode 100644 index 0000000000..e6fc4ece1e --- /dev/null +++ b/math/lapack/src/main/fortran/dsytrf_rk.f @@ -0,0 +1,498 @@ +*> \brief \b DSYTRF_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRF_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), E ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DSYTRF_RK computes the factorization of a real symmetric matrix A +*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> For more information see Further Details section. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. For more info see Further +*> Details section. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension ( MAX(1,LWORK) ). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned +*> by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array, returns this value as the first entry of the WORK +*> array, and no error message related to LWORK is issued +*> by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> TODO: put correct description +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, IP, IWS, K, KB, LDWORK, LWKOPT, + $ NB, NBMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLASYF_RK, DSYTF2_RK, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size +* + NB = ILAENV( 1, 'DSYTRF_RK', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRF_RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF_RK', + $ UPLO, N, -1, -1, -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by DLASYF_RK; +* KB is either NB or NB-1, or K for the last block +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 15 +* + IF( K.GT.NB ) THEN +* +* Factorize columns k-kb+1:k of A and use blocked code to +* update columns 1:k-kb +* + CALL DLASYF_RK( UPLO, K, NB, KB, A, LDA, E, + $ IPIV, WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL DSYTF2_RK( UPLO, K, A, LDA, E, IPIV, IINFO ) + KB = K + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* No need to adjust IPIV +* +* +* Apply permutations to the leading panel 1:k-1 +* +* Read IPIV from the last block factored, i.e. +* indices k-kb+1:k and apply row permutations to the +* last k+1 colunms k+1:N after that block +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + IF( K.LT.N ) THEN + DO I = K, ( K - KB + 1 ), -1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + CALL DSWAP( N-K, A( I, K+1 ), LDA, + $ A( IP, K+1 ), LDA ) + END IF + END DO + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* +* This label is the exit from main loop over K decreasing +* from N to 1 in steps of KB +* + 15 CONTINUE +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by DLASYF_RK; +* KB is either NB or NB-1, or N-K+1 for the last block +* + K = 1 + 20 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 35 +* + IF( K.LE.N-NB ) THEN +* +* Factorize columns k:k+kb-1 of A and use blocked code to +* update columns k+kb:n +* + CALL DLASYF_RK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, E( K ), + $ IPIV( K ), WORK, LDWORK, IINFO ) + + + ELSE +* +* Use unblocked code to factorize columns k:n of A +* + CALL DSYTF2_RK( UPLO, N-K+1, A( K, K ), LDA, E( K ), + $ IPIV( K ), IINFO ) + KB = N - K + 1 +* + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* Adjust IPIV +* + DO I = K, K + KB - 1 + IF( IPIV( I ).GT.0 ) THEN + IPIV( I ) = IPIV( I ) + K - 1 + ELSE + IPIV( I ) = IPIV( I ) - K + 1 + END IF + END DO +* +* Apply permutations to the leading panel 1:k-1 +* +* Read IPIV from the last block factored, i.e. +* indices k:k+kb-1 and apply row permutations to the +* first k-1 colunms 1:k-1 before that block +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + IF( K.GT.1 ) THEN + DO I = K, ( K + KB - 1 ), 1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + CALL DSWAP( K-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END DO + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KB + GO TO 20 +* +* This label is the exit from main loop over K increasing +* from 1 to N in steps of KB +* + 35 CONTINUE +* +* End Lower +* + END IF +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of DSYTRF_RK +* + END diff --git a/math/lapack/src/main/fortran/dsytrf_rook.f b/math/lapack/src/main/fortran/dsytrf_rook.f new file mode 100644 index 0000000000..d2690499f1 --- /dev/null +++ b/math/lapack/src/main/fortran/dsytrf_rook.f @@ -0,0 +1,393 @@ +*> \brief \b DSYTRF_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRF_ROOK computes the factorization of a real symmetric matrix A +*> using the bounded Bunch-Kaufman ("rook") 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, 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). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> 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 IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> 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 IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, 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**T, 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). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2012, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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_ROOK, DSYTF2_ROOK, 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_ROOK', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( 1, N*NB ) + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRF_ROOK', -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_ROOK', + $ UPLO, N, -1, -1, -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by DLASYF_ROOK; +* 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_ROOK( UPLO, K, NB, KB, A, LDA, + $ IPIV, WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL DSYTF2_ROOK( 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 +* +* No need to adjust IPIV +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by DLASYF_ROOK; +* 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_ROOK( 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_ROOK( 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_ROOK +* + END diff --git a/math/lapack/src/main/fortran/dsytri.f b/math/lapack/src/main/fortran/dsytri.f new file mode 100644 index 0000000000..f093a13992 --- /dev/null +++ b/math/lapack/src/main/fortran/dsytri.f @@ -0,0 +1,382 @@ +*> \brief \b DSYTRI +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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**T. +* +* 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**T. +* +* 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/math/lapack/src/main/fortran/dsytri2.f b/math/lapack/src/main/fortran/dsytri2.f new file mode 100644 index 0000000000..0d5b029d66 --- /dev/null +++ b/math/lapack/src/main/fortran/dsytri2.f @@ -0,0 +1,205 @@ +*> \brief \b DSYTRI2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRI2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRI2 computes the inverse of a DOUBLE PRECISION symmetric indefinite matrix +*> A using the factorization A = U*D*U**T or A = L*D*L**T computed by +*> DSYTRF. DSYTRI2 sets the LEADING DIMENSION of the workspace +*> before calling DSYTRI2X that actually computes the inverse. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the NB 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the NB structure of D +*> as determined by DSYTRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N+NB+1)*(NB+3) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> WORK is size >= (N+NB+1)*(NB+3) +*> If LDWORK = -1, then a workspace query is assumed; the routine +*> calculates: +*> - the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, +*> - and no error message related to LDWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL UPPER, LQUERY + INTEGER MINSIZE, NBMAX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DSYTRI, DSYTRI2X +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* Get blocksize + NBMAX = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 ) + IF ( NBMAX .GE. N ) THEN + MINSIZE = N + ELSE + MINSIZE = (N+NBMAX+1)*(NBMAX+3) + END IF +* + 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. MINSIZE .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* +* Quick return if possible +* +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRI2', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + WORK(1)=MINSIZE + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN + + IF( NBMAX .GE. N ) THEN + CALL DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) + ELSE + CALL DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NBMAX, INFO ) + END IF + RETURN +* +* End of DSYTRI2 +* + END diff --git a/math/lapack/src/main/fortran/dsytri2x.f b/math/lapack/src/main/fortran/dsytri2x.f new file mode 100644 index 0000000000..bcd5c94249 --- /dev/null +++ b/math/lapack/src/main/fortran/dsytri2x.f @@ -0,0 +1,591 @@ +*> \brief \b DSYTRI2X +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRI2X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( N+NB+1,* ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRI2X 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the NNB 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the NNB structure of D +*> as determined by DSYTRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N+NNB+1,NNB+3) +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( N+NB+1,* ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IINFO, IP, K, CUT, NNB + INTEGER COUNT + INTEGER J, U11, INVD + + DOUBLE PRECISION AK, AKKP1, AKP1, D, T + DOUBLE PRECISION U01_I_J, U01_IP1_J + DOUBLE PRECISION U11_I_J, U11_IP1_J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSYCONV, XERBLA, DTRTRI + EXTERNAL DGEMM, DTRMM, DSYSWAPR +* .. +* .. 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 + END IF +* +* Quick return if possible +* +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRI2X', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN +* +* Convert A +* Workspace got Non-diag elements of D +* + CALL DSYCONV( UPLO, 'C', N, A, LDA, IPIV, WORK, IINFO ) +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) + $ RETURN + END DO + END IF + INFO = 0 +* +* Splitting Workspace +* U01 is a block (N,NB+1) +* The first element of U01 is in WORK(1,1) +* U11 is a block (NB+1,NB+1) +* The first element of U11 is in WORK(N+1,1) + U11 = N +* INVD is a block (N,2) +* The first element of INVD is in WORK(1,INVD) + INVD = NB+2 + + IF( UPPER ) THEN +* +* invA = P * inv(U**T)*inv(D)*inv(U)*P**T. +* + CALL DTRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D)*inv(U) +* + K=1 + DO WHILE ( K .LE. N ) + IF( IPIV( K ).GT.0 ) THEN +* 1 x 1 diagonal NNB + WORK(K,INVD) = ONE / A( K, K ) + WORK(K,INVD+1) = 0 + K=K+1 + ELSE +* 2 x 2 diagonal NNB + T = WORK(K+1,1) + AK = A( K, K ) / T + AKP1 = A( K+1, K+1 ) / T + AKKP1 = WORK(K+1,1) / T + D = T*( AK*AKP1-ONE ) + WORK(K,INVD) = AKP1 / D + WORK(K+1,INVD+1) = AK / D + WORK(K,INVD+1) = -AKKP1 / D + WORK(K+1,INVD) = -AKKP1 / D + K=K+2 + END IF + END DO +* +* inv(U**T) = (inv(U))**T +* +* inv(U**T)*inv(D)*inv(U) +* + CUT=N + DO WHILE (CUT .GT. 0) + NNB=NB + IF (CUT .LE. NNB) THEN + NNB=CUT + ELSE + COUNT = 0 +* count negative elements, + DO I=CUT+1-NNB,CUT + IF (IPIV(I) .LT. 0) COUNT=COUNT+1 + END DO +* need a even number for a clear cut + IF (MOD(COUNT,2) .EQ. 1) NNB=NNB+1 + END IF + + CUT=CUT-NNB +* +* U01 Block +* + DO I=1,CUT + DO J=1,NNB + WORK(I,J)=A(I,CUT+J) + END DO + END DO +* +* U11 Block +* + DO I=1,NNB + WORK(U11+I,I)=ONE + DO J=1,I-1 + WORK(U11+I,J)=ZERO + END DO + DO J=I+1,NNB + WORK(U11+I,J)=A(CUT+I,CUT+J) + END DO + END DO +* +* invD*U01 +* + I=1 + DO WHILE (I .LE. CUT) + IF (IPIV(I) > 0) THEN + DO J=1,NNB + WORK(I,J)=WORK(I,INVD)*WORK(I,J) + END DO + I=I+1 + ELSE + DO J=1,NNB + U01_I_J = WORK(I,J) + U01_IP1_J = WORK(I+1,J) + WORK(I,J)=WORK(I,INVD)*U01_I_J+ + $ WORK(I,INVD+1)*U01_IP1_J + WORK(I+1,J)=WORK(I+1,INVD)*U01_I_J+ + $ WORK(I+1,INVD+1)*U01_IP1_J + END DO + I=I+2 + END IF + END DO +* +* invD1*U11 +* + I=1 + DO WHILE (I .LE. NNB) + IF (IPIV(CUT+I) > 0) THEN + DO J=I,NNB + WORK(U11+I,J)=WORK(CUT+I,INVD)*WORK(U11+I,J) + END DO + I=I+1 + ELSE + DO J=I,NNB + U11_I_J = WORK(U11+I,J) + U11_IP1_J = WORK(U11+I+1,J) + WORK(U11+I,J)=WORK(CUT+I,INVD)*WORK(U11+I,J) + + $ WORK(CUT+I,INVD+1)*WORK(U11+I+1,J) + WORK(U11+I+1,J)=WORK(CUT+I+1,INVD)*U11_I_J+ + $ WORK(CUT+I+1,INVD+1)*U11_IP1_J + END DO + I=I+2 + END IF + END DO +* +* U11**T*invD1*U11->U11 +* + CALL DTRMM('L','U','T','U',NNB, NNB, + $ ONE,A(CUT+1,CUT+1),LDA,WORK(U11+1,1),N+NB+1) +* + DO I=1,NNB + DO J=I,NNB + A(CUT+I,CUT+J)=WORK(U11+I,J) + END DO + END DO +* +* U01**T*invD*U01->A(CUT+I,CUT+J) +* + CALL DGEMM('T','N',NNB,NNB,CUT,ONE,A(1,CUT+1),LDA, + $ WORK,N+NB+1, ZERO, WORK(U11+1,1), N+NB+1) + +* +* U11 = U11**T*invD1*U11 + U01**T*invD*U01 +* + DO I=1,NNB + DO J=I,NNB + A(CUT+I,CUT+J)=A(CUT+I,CUT+J)+WORK(U11+I,J) + END DO + END DO +* +* U01 = U00**T*invD0*U01 +* + CALL DTRMM('L',UPLO,'T','U',CUT, NNB, + $ ONE,A,LDA,WORK,N+NB+1) + +* +* Update U01 +* + DO I=1,CUT + DO J=1,NNB + A(I,CUT+J)=WORK(I,J) + END DO + END DO +* +* Next Block +* + END DO +* +* Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T +* + I=1 + DO WHILE ( I .LE. N ) + IF( IPIV(I) .GT. 0 ) THEN + IP=IPIV(I) + IF (I .LT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, I ,IP ) + IF (I .GT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, IP ,I ) + ELSE + IP=-IPIV(I) + I=I+1 + IF ( (I-1) .LT. IP) + $ CALL DSYSWAPR( UPLO, N, A, LDA, I-1 ,IP ) + IF ( (I-1) .GT. IP) + $ CALL DSYSWAPR( UPLO, N, A, LDA, IP ,I-1 ) + ENDIF + I=I+1 + END DO + ELSE +* +* LOWER... +* +* invA = P * inv(U**T)*inv(D)*inv(U)*P**T. +* + CALL DTRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D)*inv(U) +* + K=N + DO WHILE ( K .GE. 1 ) + IF( IPIV( K ).GT.0 ) THEN +* 1 x 1 diagonal NNB + WORK(K,INVD) = ONE / A( K, K ) + WORK(K,INVD+1) = 0 + K=K-1 + ELSE +* 2 x 2 diagonal NNB + T = WORK(K-1,1) + AK = A( K-1, K-1 ) / T + AKP1 = A( K, K ) / T + AKKP1 = WORK(K-1,1) / T + D = T*( AK*AKP1-ONE ) + WORK(K-1,INVD) = AKP1 / D + WORK(K,INVD) = AK / D + WORK(K,INVD+1) = -AKKP1 / D + WORK(K-1,INVD+1) = -AKKP1 / D + K=K-2 + END IF + END DO +* +* inv(U**T) = (inv(U))**T +* +* inv(U**T)*inv(D)*inv(U) +* + CUT=0 + DO WHILE (CUT .LT. N) + NNB=NB + IF (CUT + NNB .GT. N) THEN + NNB=N-CUT + ELSE + COUNT = 0 +* count negative elements, + DO I=CUT+1,CUT+NNB + IF (IPIV(I) .LT. 0) COUNT=COUNT+1 + END DO +* need a even number for a clear cut + IF (MOD(COUNT,2) .EQ. 1) NNB=NNB+1 + END IF +* L21 Block + DO I=1,N-CUT-NNB + DO J=1,NNB + WORK(I,J)=A(CUT+NNB+I,CUT+J) + END DO + END DO +* L11 Block + DO I=1,NNB + WORK(U11+I,I)=ONE + DO J=I+1,NNB + WORK(U11+I,J)=ZERO + END DO + DO J=1,I-1 + WORK(U11+I,J)=A(CUT+I,CUT+J) + END DO + END DO +* +* invD*L21 +* + I=N-CUT-NNB + DO WHILE (I .GE. 1) + IF (IPIV(CUT+NNB+I) > 0) THEN + DO J=1,NNB + WORK(I,J)=WORK(CUT+NNB+I,INVD)*WORK(I,J) + END DO + I=I-1 + ELSE + DO J=1,NNB + U01_I_J = WORK(I,J) + U01_IP1_J = WORK(I-1,J) + WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+ + $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J + WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+ + $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J + END DO + I=I-2 + END IF + END DO +* +* invD1*L11 +* + I=NNB + DO WHILE (I .GE. 1) + IF (IPIV(CUT+I) > 0) THEN + DO J=1,NNB + WORK(U11+I,J)=WORK(CUT+I,INVD)*WORK(U11+I,J) + END DO + I=I-1 + ELSE + DO J=1,NNB + U11_I_J = WORK(U11+I,J) + U11_IP1_J = WORK(U11+I-1,J) + WORK(U11+I,J)=WORK(CUT+I,INVD)*WORK(U11+I,J) + + $ WORK(CUT+I,INVD+1)*U11_IP1_J + WORK(U11+I-1,J)=WORK(CUT+I-1,INVD+1)*U11_I_J+ + $ WORK(CUT+I-1,INVD)*U11_IP1_J + END DO + I=I-2 + END IF + END DO +* +* L11**T*invD1*L11->L11 +* + CALL DTRMM('L',UPLO,'T','U',NNB, NNB, + $ ONE,A(CUT+1,CUT+1),LDA,WORK(U11+1,1),N+NB+1) + +* + DO I=1,NNB + DO J=1,I + A(CUT+I,CUT+J)=WORK(U11+I,J) + END DO + END DO +* + IF ( (CUT+NNB) .LT. N ) THEN +* +* L21**T*invD2*L21->A(CUT+I,CUT+J) +* + CALL DGEMM('T','N',NNB,NNB,N-NNB-CUT,ONE,A(CUT+NNB+1,CUT+1) + $ ,LDA,WORK,N+NB+1, ZERO, WORK(U11+1,1), N+NB+1) + +* +* L11 = L11**T*invD1*L11 + U01**T*invD*U01 +* + DO I=1,NNB + DO J=1,I + A(CUT+I,CUT+J)=A(CUT+I,CUT+J)+WORK(U11+I,J) + END DO + END DO +* +* L01 = L22**T*invD2*L21 +* + CALL DTRMM('L',UPLO,'T','U', N-NNB-CUT, NNB, + $ ONE,A(CUT+NNB+1,CUT+NNB+1),LDA,WORK,N+NB+1) +* +* Update L21 +* + DO I=1,N-CUT-NNB + DO J=1,NNB + A(CUT+NNB+I,CUT+J)=WORK(I,J) + END DO + END DO + + ELSE +* +* L11 = L11**T*invD1*L11 +* + DO I=1,NNB + DO J=1,I + A(CUT+I,CUT+J)=WORK(U11+I,J) + END DO + END DO + END IF +* +* Next Block +* + CUT=CUT+NNB + END DO +* +* Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T +* + I=N + DO WHILE ( I .GE. 1 ) + IF( IPIV(I) .GT. 0 ) THEN + IP=IPIV(I) + IF (I .LT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, I ,IP ) + IF (I .GT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, IP ,I ) + ELSE + IP=-IPIV(I) + IF ( I .LT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, I ,IP ) + IF ( I .GT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, IP, I ) + I=I-1 + ENDIF + I=I-1 + END DO + END IF +* + RETURN +* +* End of DSYTRI2X +* + END + diff --git a/math/lapack/src/main/fortran/dsytri_3.f b/math/lapack/src/main/fortran/dsytri_3.f new file mode 100644 index 0000000000..f177bec241 --- /dev/null +++ b/math/lapack/src/main/fortran/dsytri_3.f @@ -0,0 +1,248 @@ +*> \brief \b DSYTRI_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRI_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DSYTRI_3 computes the inverse of a real symmetric indefinite +*> matrix A using the factorization computed by DSYTRF_RK or DSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> DSYTRI_3 sets the leading dimension of the workspace before calling +*> DSYTRI_3X that actually computes the inverse. This is the blocked +*> version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, diagonal of the block diagonal matrix D and +*> factors U or L as computed by DSYTRF_RK and DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, if INFO = 0, the symmetric inverse of the original +*> matrix. +*> If UPLO = 'U': the upper triangular part of the inverse +*> is formed and the part of A below the diagonal is not +*> referenced; +*> If UPLO = 'L': the lower triangular part of the inverse +*> is formed and the part of A above the diagonal is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF_RK or DSYTRF_BK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N+NB+1)*(NB+3). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= (N+NB+1)*(NB+3). +*> +*> If LDWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the optimal +*> size of the WORK array, returns this value as the first +*> entry of the WORK array, and no error message related to +*> LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL UPPER, LQUERY + INTEGER LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DSYTRI_3X +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* Determine the block size +* + NB = MAX( 1, ILAENV( 1, 'DSYTRI_3', UPLO, N, -1, -1, -1 ) ) + LWKOPT = ( N+NB+1 ) * ( NB+3 ) +* + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LWORK .LT. LWKOPT .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRI_3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + WORK( 1 ) = LWKOPT + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + CALL DSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYTRI_3 +* + END diff --git a/math/lapack/src/main/fortran/dsytri_3x.f b/math/lapack/src/main/fortran/dsytri_3x.f new file mode 100644 index 0000000000..83ad1d125f --- /dev/null +++ b/math/lapack/src/main/fortran/dsytri_3x.f @@ -0,0 +1,645 @@ +*> \brief \b DSYTRI_3X +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRI_3X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), E( * ), WORK( N+NB+1, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DSYTRI_3X computes the inverse of a real symmetric indefinite +*> matrix A using the factorization computed by DSYTRF_RK or DSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, diagonal of the block diagonal matrix D and +*> factors U or L as computed by DSYTRF_RK and DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, if INFO = 0, the symmetric inverse of the original +*> matrix. +*> If UPLO = 'U': the upper triangular part of the inverse +*> is formed and the part of A below the diagonal is not +*> referenced; +*> If UPLO = 'L': the lower triangular part of the inverse +*> is formed and the part of A above the diagonal is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) not refernced; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF_RK or DSYTRF_BK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N+NB+1,NB+3). +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), E( * ), WORK( N+NB+1, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER CUT, I, ICOUNT, INVD, IP, K, NNB, J, U11 + DOUBLE PRECISION AK, AKKP1, AKP1, D, T, U01_I_J, U01_IP1_J, + $ U11_I_J, U11_IP1_J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DSYSWAPR, DTRTRI, DTRMM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF +* +* Quick return if possible +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRI_3X', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN +* +* Workspace got Non-diag elements of D +* + DO K = 1, N + WORK( K, 1 ) = E( K ) + END DO +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) + $ RETURN + END DO + END IF +* + INFO = 0 +* +* Splitting Workspace +* U01 is a block ( N, NB+1 ) +* The first element of U01 is in WORK( 1, 1 ) +* U11 is a block ( NB+1, NB+1 ) +* The first element of U11 is in WORK( N+1, 1 ) +* + U11 = N +* +* INVD is a block ( N, 2 ) +* The first element of INVD is in WORK( 1, INVD ) +* + INVD = NB + 2 + + IF( UPPER ) THEN +* +* Begin Upper +* +* invA = P * inv(U**T) * inv(D) * inv(U) * P**T. +* + CALL DTRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D) * inv(U) +* + K = 1 + DO WHILE( K.LE.N ) + IF( IPIV( K ).GT.0 ) THEN +* 1 x 1 diagonal NNB + WORK( K, INVD ) = ONE / A( K, K ) + WORK( K, INVD+1 ) = ZERO + ELSE +* 2 x 2 diagonal NNB + T = WORK( K+1, 1 ) + AK = A( K, K ) / T + AKP1 = A( K+1, K+1 ) / T + AKKP1 = WORK( K+1, 1 ) / T + D = T*( AK*AKP1-ONE ) + WORK( K, INVD ) = AKP1 / D + WORK( K+1, INVD+1 ) = AK / D + WORK( K, INVD+1 ) = -AKKP1 / D + WORK( K+1, INVD ) = WORK( K, INVD+1 ) + K = K + 1 + END IF + K = K + 1 + END DO +* +* inv(U**T) = (inv(U))**T +* +* inv(U**T) * inv(D) * inv(U) +* + CUT = N + DO WHILE( CUT.GT.0 ) + NNB = NB + IF( CUT.LE.NNB ) THEN + NNB = CUT + ELSE + ICOUNT = 0 +* count negative elements, + DO I = CUT+1-NNB, CUT + IF( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1 + END DO +* need a even number for a clear cut + IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1 + END IF + + CUT = CUT - NNB +* +* U01 Block +* + DO I = 1, CUT + DO J = 1, NNB + WORK( I, J ) = A( I, CUT+J ) + END DO + END DO +* +* U11 Block +* + DO I = 1, NNB + WORK( U11+I, I ) = ONE + DO J = 1, I-1 + WORK( U11+I, J ) = ZERO + END DO + DO J = I+1, NNB + WORK( U11+I, J ) = A( CUT+I, CUT+J ) + END DO + END DO +* +* invD * U01 +* + I = 1 + DO WHILE( I.LE.CUT ) + IF( IPIV( I ).GT.0 ) THEN + DO J = 1, NNB + WORK( I, J ) = WORK( I, INVD ) * WORK( I, J ) + END DO + ELSE + DO J = 1, NNB + U01_I_J = WORK( I, J ) + U01_IP1_J = WORK( I+1, J ) + WORK( I, J ) = WORK( I, INVD ) * U01_I_J + $ + WORK( I, INVD+1 ) * U01_IP1_J + WORK( I+1, J ) = WORK( I+1, INVD ) * U01_I_J + $ + WORK( I+1, INVD+1 ) * U01_IP1_J + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* invD1 * U11 +* + I = 1 + DO WHILE ( I.LE.NNB ) + IF( IPIV( CUT+I ).GT.0 ) THEN + DO J = I, NNB + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + END DO + ELSE + DO J = I, NNB + U11_I_J = WORK(U11+I,J) + U11_IP1_J = WORK(U11+I+1,J) + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + $ + WORK(CUT+I,INVD+1) * WORK(U11+I+1,J) + WORK( U11+I+1, J ) = WORK(CUT+I+1,INVD) * U11_I_J + $ + WORK(CUT+I+1,INVD+1) * U11_IP1_J + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* U11**T * invD1 * U11 -> U11 +* + CALL DTRMM( 'L', 'U', 'T', 'U', NNB, NNB, + $ ONE, A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ), + $ N+NB+1 ) +* + DO I = 1, NNB + DO J = I, NNB + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO +* +* U01**T * invD * U01 -> A( CUT+I, CUT+J ) +* + CALL DGEMM( 'T', 'N', NNB, NNB, CUT, ONE, A( 1, CUT+1 ), + $ LDA, WORK, N+NB+1, ZERO, WORK(U11+1,1), N+NB+1 ) + +* +* U11 = U11**T * invD1 * U11 + U01**T * invD * U01 +* + DO I = 1, NNB + DO J = I, NNB + A( CUT+I, CUT+J ) = A( CUT+I, CUT+J ) + WORK(U11+I,J) + END DO + END DO +* +* U01 = U00**T * invD0 * U01 +* + CALL DTRMM( 'L', UPLO, 'T', 'U', CUT, NNB, + $ ONE, A, LDA, WORK, N+NB+1 ) + +* +* Update U01 +* + DO I = 1, CUT + DO J = 1, NNB + A( I, CUT+J ) = WORK( I, J ) + END DO + END DO +* +* Next Block +* + END DO +* +* Apply PERMUTATIONS P and P**T: +* P * inv(U**T) * inv(D) * inv(U) * P**T. +* Interchange rows and columns I and IPIV(I) in reverse order +* from the formation order of IPIV vector for Upper case. +* +* ( We can use a loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row (column) +* index of the interchange with row (column) i in both 1x1 +* and 2x2 pivot cases, i.e. we don't need separate code branches +* for 1x1 and 2x2 pivot cases ) +* + DO I = 1, N + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + IF (I .LT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, I ,IP ) + IF (I .GT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, IP ,I ) + END IF + END DO +* + ELSE +* +* Begin Lower +* +* inv A = P * inv(L**T) * inv(D) * inv(L) * P**T. +* + CALL DTRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D) * inv(L) +* + K = N + DO WHILE ( K .GE. 1 ) + IF( IPIV( K ).GT.0 ) THEN +* 1 x 1 diagonal NNB + WORK( K, INVD ) = ONE / A( K, K ) + WORK( K, INVD+1 ) = ZERO + ELSE +* 2 x 2 diagonal NNB + T = WORK( K-1, 1 ) + AK = A( K-1, K-1 ) / T + AKP1 = A( K, K ) / T + AKKP1 = WORK( K-1, 1 ) / T + D = T*( AK*AKP1-ONE ) + WORK( K-1, INVD ) = AKP1 / D + WORK( K, INVD ) = AK / D + WORK( K, INVD+1 ) = -AKKP1 / D + WORK( K-1, INVD+1 ) = WORK( K, INVD+1 ) + K = K - 1 + END IF + K = K - 1 + END DO +* +* inv(L**T) = (inv(L))**T +* +* inv(L**T) * inv(D) * inv(L) +* + CUT = 0 + DO WHILE( CUT.LT.N ) + NNB = NB + IF( (CUT + NNB).GT.N ) THEN + NNB = N - CUT + ELSE + ICOUNT = 0 +* count negative elements, + DO I = CUT + 1, CUT+NNB + IF ( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1 + END DO +* need a even number for a clear cut + IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1 + END IF +* +* L21 Block +* + DO I = 1, N-CUT-NNB + DO J = 1, NNB + WORK( I, J ) = A( CUT+NNB+I, CUT+J ) + END DO + END DO +* +* L11 Block +* + DO I = 1, NNB + WORK( U11+I, I) = ONE + DO J = I+1, NNB + WORK( U11+I, J ) = ZERO + END DO + DO J = 1, I-1 + WORK( U11+I, J ) = A( CUT+I, CUT+J ) + END DO + END DO +* +* invD*L21 +* + I = N-CUT-NNB + DO WHILE( I.GE.1 ) + IF( IPIV( CUT+NNB+I ).GT.0 ) THEN + DO J = 1, NNB + WORK( I, J ) = WORK( CUT+NNB+I, INVD) * WORK( I, J) + END DO + ELSE + DO J = 1, NNB + U01_I_J = WORK(I,J) + U01_IP1_J = WORK(I-1,J) + WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+ + $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J + WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+ + $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* invD1*L11 +* + I = NNB + DO WHILE( I.GE.1 ) + IF( IPIV( CUT+I ).GT.0 ) THEN + DO J = 1, NNB + WORK( U11+I, J ) = WORK( CUT+I, INVD)*WORK(U11+I,J) + END DO + + ELSE + DO J = 1, NNB + U11_I_J = WORK( U11+I, J ) + U11_IP1_J = WORK( U11+I-1, J ) + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + $ + WORK(CUT+I,INVD+1) * U11_IP1_J + WORK( U11+I-1, J ) = WORK(CUT+I-1,INVD+1) * U11_I_J + $ + WORK(CUT+I-1,INVD) * U11_IP1_J + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* L11**T * invD1 * L11 -> L11 +* + CALL DTRMM( 'L', UPLO, 'T', 'U', NNB, NNB, ONE, + $ A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ), + $ N+NB+1 ) + +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO +* + IF( (CUT+NNB).LT.N ) THEN +* +* L21**T * invD2*L21 -> A( CUT+I, CUT+J ) +* + CALL DGEMM( 'T', 'N', NNB, NNB, N-NNB-CUT, ONE, + $ A( CUT+NNB+1, CUT+1 ), LDA, WORK, N+NB+1, + $ ZERO, WORK( U11+1, 1 ), N+NB+1 ) + +* +* L11 = L11**T * invD1 * L11 + U01**T * invD * U01 +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = A( CUT+I, CUT+J )+WORK(U11+I,J) + END DO + END DO +* +* L01 = L22**T * invD2 * L21 +* + CALL DTRMM( 'L', UPLO, 'T', 'U', N-NNB-CUT, NNB, ONE, + $ A( CUT+NNB+1, CUT+NNB+1 ), LDA, WORK, + $ N+NB+1 ) +* +* Update L21 +* + DO I = 1, N-CUT-NNB + DO J = 1, NNB + A( CUT+NNB+I, CUT+J ) = WORK( I, J ) + END DO + END DO +* + ELSE +* +* L11 = L11**T * invD1 * L11 +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO + END IF +* +* Next Block +* + CUT = CUT + NNB +* + END DO +* +* Apply PERMUTATIONS P and P**T: +* P * inv(L**T) * inv(D) * inv(L) * P**T. +* Interchange rows and columns I and IPIV(I) in reverse order +* from the formation order of IPIV vector for Lower case. +* +* ( We can use a loop over IPIV with increment -1, +* since the ABS value of IPIV(I) represents the row (column) +* index of the interchange with row (column) i in both 1x1 +* and 2x2 pivot cases, i.e. we don't need separate code branches +* for 1x1 and 2x2 pivot cases ) +* + DO I = N, 1, -1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + IF (I .LT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, I ,IP ) + IF (I .GT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, IP ,I ) + END IF + END DO +* + END IF +* + RETURN +* +* End of DSYTRI_3X +* + END + diff --git a/math/lapack/src/main/fortran/dsytri_rook.f b/math/lapack/src/main/fortran/dsytri_rook.f new file mode 100644 index 0000000000..cad2a7e9f3 --- /dev/null +++ b/math/lapack/src/main/fortran/dsytri_rook.f @@ -0,0 +1,450 @@ +*> \brief \b DSYTRI_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRI_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRI_ROOK computes the inverse of a real symmetric +*> matrix A using the factorization A = U*D*U**T or A = L*D*L**T +*> computed by DSYTRF_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the block diagonal matrix D and the multipliers +*> used to obtain the factor U or L as computed by DSYTRF_ROOK. +*> +*> On exit, if INFO = 0, the (symmetric) inverse of the original +*> matrix. If UPLO = 'U', the upper triangular part of the +*> inverse is formed and the part of A below the diagonal is not +*> referenced; if UPLO = 'L' the lower triangular part of the +*> inverse is formed and the part of A above the diagonal is +*> not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF_ROOK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2012, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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_ROOK', -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**T. +* +* 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 +* + IF( KSTEP.EQ.1 ) THEN +* +* Interchange rows and columns K and IPIV(K) in the leading +* submatrix A(1:k+1,1:k+1) +* + KP = IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.GT.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 + END IF + ELSE +* +* Interchange rows and columns K and K+1 with -IPIV(K) and +* -IPIV(K+1)in the leading submatrix A(1:k+1,1:k+1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.GT.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 + TEMP = A( K, K+1 ) + A( K, K+1 ) = A( KP, K+1 ) + A( KP, K+1 ) = TEMP + END IF +* + K = K + 1 + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.GT.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 + END IF + END IF +* + K = K + 1 + GO TO 30 + 40 CONTINUE +* + ELSE +* +* Compute inv(A) from the factorization A = L*D*L**T. +* +* 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 +* + IF( KSTEP.EQ.1 ) THEN +* +* Interchange rows and columns K and IPIV(K) in the trailing +* submatrix A(k-1:n,k-1:n) +* + KP = IPIV( K ) + IF( KP.NE.K ) THEN + 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 + END IF + ELSE +* +* Interchange rows and columns K and K-1 with -IPIV(K) and +* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n) +* + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + 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 + TEMP = A( K, K-1 ) + A( K, K-1 ) = A( KP, K-1 ) + A( KP, K-1 ) = TEMP + END IF +* + K = K - 1 + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + 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 + END IF + END IF +* + K = K - 1 + GO TO 50 + 60 CONTINUE + END IF +* + RETURN +* +* End of DSYTRI_ROOK +* + END diff --git a/math/lapack/src/main/fortran/dsytrs.f b/math/lapack/src/main/fortran/dsytrs.f new file mode 100644 index 0000000000..e5988f20f3 --- /dev/null +++ b/math/lapack/src/main/fortran/dsytrs.f @@ -0,0 +1,445 @@ +*> \brief \b DSYTRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. 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**T. +* +* 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**T *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**T(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**T(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**T. +* +* 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**T *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**T(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**T(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/math/lapack/src/main/fortran/dsytrs2.f b/math/lapack/src/main/fortran/dsytrs2.f new file mode 100644 index 0000000000..c7ca8e9ffa --- /dev/null +++ b/math/lapack/src/main/fortran/dsytrs2.f @@ -0,0 +1,361 @@ +*> \brief \b DSYTRS2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRS2 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 and converted by DSYCONV. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> Note that A is input / output. This might be counter-intuitive, +*> and one may think that A is input only. A is input / output. This +*> is because, at the start of the subroutine, we permute A in a +*> "better" form and then we permute A back to its original form at +*> the end. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IINFO, J, K, KP + DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSYCONV, DSWAP, DTRSM, 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( 'DSYTRS2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* +* Convert A +* + CALL DSYCONV( UPLO, 'C', N, A, LDA, IPIV, WORK, IINFO ) +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*D*U**T. +* +* P**T * B + K=N + DO WHILE ( K .GE. 1 ) + 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 ) + K=K-1 + ELSE +* 2 x 2 diagonal block +* Interchange rows K-1 and -IPIV(K). + KP = -IPIV( K ) + IF( KP.EQ.-IPIV( K-1 ) ) + $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) + K=K-2 + END IF + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL DTRSM('L','U','N','U',N,NRHS,ONE,A,LDA,B,LDB) +* +* Compute D \ B -> B [ D \ (U \P**T * B) ] +* + I=N + DO WHILE ( I .GE. 1 ) + IF( IPIV(I) .GT. 0 ) THEN + CALL DSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB ) + ELSEIF ( I .GT. 1) THEN + IF ( IPIV(I-1) .EQ. IPIV(I) ) THEN + AKM1K = WORK(I) + AKM1 = A( I-1, I-1 ) / AKM1K + AK = A( I, I ) / AKM1K + DENOM = AKM1*AK - ONE + DO 15 J = 1, NRHS + BKM1 = B( I-1, J ) / AKM1K + BK = B( I, J ) / AKM1K + B( I-1, J ) = ( AK*BKM1-BK ) / DENOM + B( I, J ) = ( AKM1*BK-BKM1 ) / DENOM + 15 CONTINUE + I = I - 1 + ENDIF + ENDIF + I = I - 1 + END DO +* +* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ] +* + CALL DTRSM('L','U','T','U',N,NRHS,ONE,A,LDA,B,LDB) +* +* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ] +* + K=1 + DO WHILE ( K .LE. N ) + 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 ) + K=K+1 + ELSE +* 2 x 2 diagonal block +* Interchange rows K-1 and -IPIV(K). + KP = -IPIV( K ) + IF( K .LT. N .AND. KP.EQ.-IPIV( K+1 ) ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K=K+2 + ENDIF + END DO +* + ELSE +* +* Solve A*X = B, where A = L*D*L**T. +* +* P**T * B + K=1 + DO WHILE ( K .LE. N ) + 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 ) + K=K+1 + ELSE +* 2 x 2 diagonal block +* Interchange rows K and -IPIV(K+1). + KP = -IPIV( K+1 ) + IF( KP.EQ.-IPIV( K ) ) + $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) + K=K+2 + ENDIF + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL DTRSM('L','L','N','U',N,NRHS,ONE,A,LDA,B,LDB) +* +* Compute D \ B -> B [ D \ (L \P**T * B) ] +* + I=1 + DO WHILE ( I .LE. N ) + IF( IPIV(I) .GT. 0 ) THEN + CALL DSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB ) + ELSE + AKM1K = WORK(I) + AKM1 = A( I, I ) / AKM1K + AK = A( I+1, I+1 ) / AKM1K + DENOM = AKM1*AK - ONE + DO 25 J = 1, NRHS + BKM1 = B( I, J ) / AKM1K + BK = B( I+1, J ) / AKM1K + B( I, J ) = ( AK*BKM1-BK ) / DENOM + B( I+1, J ) = ( AKM1*BK-BKM1 ) / DENOM + 25 CONTINUE + I = I + 1 + ENDIF + I = I + 1 + END DO +* +* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] +* + CALL DTRSM('L','L','T','U',N,NRHS,ONE,A,LDA,B,LDB) +* +* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] +* + K=N + DO WHILE ( K .GE. 1 ) + 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 ) + K=K-1 + ELSE +* 2 x 2 diagonal block +* Interchange rows K-1 and -IPIV(K). + KP = -IPIV( K ) + IF( K.GT.1 .AND. KP.EQ.-IPIV( K-1 ) ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K=K-2 + ENDIF + END DO +* + END IF +* +* Revert A +* + CALL DSYCONV( UPLO, 'R', N, A, LDA, IPIV, WORK, IINFO ) +* + RETURN +* +* End of DSYTRS2 +* + END diff --git a/math/lapack/src/main/fortran/dsytrs_3.f b/math/lapack/src/main/fortran/dsytrs_3.f new file mode 100644 index 0000000000..d0d303a9a4 --- /dev/null +++ b/math/lapack/src/main/fortran/dsytrs_3.f @@ -0,0 +1,371 @@ +*> \brief \b DSYTRS_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRS_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DSYTRS_3 solves a system of linear equations A * X = B with a real +*> symmetric matrix A using the factorization computed +*> by DSYTRF_RK or DSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This algorithm is using Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix: +*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T); +*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by DSYTRF_RK and DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF_RK or DSYTRF_BK. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, J, K, KP + DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRS_3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin Upper +* +* Solve A*X = B, where A = U*D*U**T. +* +* P**T * B +* +* Interchange rows K and IPIV(K) of matrix B in the same order +* that the formation order of IPIV(I) vector for Upper case. +* +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = N, 1, -1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL DTRSM( 'L', 'U', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* Compute D \ B -> B [ D \ (U \P**T * B) ] +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN + CALL DSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB ) + ELSE IF ( I.GT.1 ) THEN + AKM1K = E( I ) + AKM1 = A( I-1, I-1 ) / AKM1K + AK = A( I, I ) / AKM1K + DENOM = AKM1*AK - ONE + DO J = 1, NRHS + BKM1 = B( I-1, J ) / AKM1K + BK = B( I, J ) / AKM1K + B( I-1, J ) = ( AK*BKM1-BK ) / DENOM + B( I, J ) = ( AKM1*BK-BKM1 ) / DENOM + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ] +* + CALL DTRSM( 'L', 'U', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ] +* +* Interchange rows K and IPIV(K) of matrix B in reverse order +* from the formation order of IPIV(I) vector for Upper case. +* +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = 1, N + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* + ELSE +* +* Begin Lower +* +* Solve A*X = B, where A = L*D*L**T. +* +* P**T * B +* Interchange rows K and IPIV(K) of matrix B in the same order +* that the formation order of IPIV(I) vector for Lower case. +* +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = 1, N + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL DTRSM( 'L', 'L', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* Compute D \ B -> B [ D \ (L \P**T * B) ] +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN + CALL DSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB ) + ELSE IF( I.LT.N ) THEN + AKM1K = E( I ) + AKM1 = A( I, I ) / AKM1K + AK = A( I+1, I+1 ) / AKM1K + DENOM = AKM1*AK - ONE + DO J = 1, NRHS + BKM1 = B( I, J ) / AKM1K + BK = B( I+1, J ) / AKM1K + B( I, J ) = ( AK*BKM1-BK ) / DENOM + B( I+1, J ) = ( AKM1*BK-BKM1 ) / DENOM + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] +* + CALL DTRSM('L', 'L', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] +* +* Interchange rows K and IPIV(K) of matrix B in reverse order +* from the formation order of IPIV(I) vector for Lower case. +* +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = N, 1, -1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* END Lower +* + END IF +* + RETURN +* +* End of DSYTRS_3 +* + END diff --git a/math/lapack/src/main/fortran/dsytrs_aa.f b/math/lapack/src/main/fortran/dsytrs_aa.f new file mode 100644 index 0000000000..b572581e53 --- /dev/null +++ b/math/lapack/src/main/fortran/dsytrs_aa.f @@ -0,0 +1,285 @@ +*> \brief \b DSYTRS_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRS_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRS_AA solves a system of linear equations A*X = B with a real +*> symmetric matrix A using the factorization A = U*T*U**T or +*> A = L*T*L**T computed by DSYTRF_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*T*U**T; +*> = 'L': Lower triangular, form is A = L*T*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> Details of factors computed by DSYTRF_AA. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges as computed by DSYTRF_AA. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in] WORK +*> \verbatim +*> WORK is DOUBLE array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER, LWORK >= MAX(1,3*N-2). +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER K, KP, LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGTSV, DSWAP, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + 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( 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.MAX( 1, 3*N-2 ) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRS_AA', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + LWKOPT = (3*N-2) + WORK( 1 ) = LWKOPT + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*T*U**T. +* +* Pivot, P**T * B +* + DO K = 1, N + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL DTRSM('L', 'U', 'T', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B( 2, 1 ), LDB) +* +* Compute T \ B -> B [ T \ (U \P**T * B) ] +* + CALL DLACPY( 'F', 1, N, A( 1, 1 ), LDA+1, WORK( N ), 1) + IF( N.GT.1 ) THEN + CALL DLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 1 ), 1 ) + CALL DLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 2*N ), 1 ) + END IF + CALL DGTSV( N, NRHS, WORK( 1 ), WORK( N ), WORK( 2*N ), B, LDB, + $ INFO ) +* +* Compute (U**T \ B) -> B [ U**T \ (T \ (U \P**T * B) ) ] +* + CALL DTRSM( 'L', 'U', 'N', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B( 2, 1 ), LDB) +* +* Pivot, P * B [ P * (U**T \ (T \ (U \P**T * B) )) ] +* + DO K = N, 1, -1 + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* + ELSE +* +* Solve A*X = B, where A = L*T*L**T. +* +* Pivot, P**T * B +* + DO K = 1, N + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL DTRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B( 2, 1 ), LDB) +* +* Compute T \ B -> B [ T \ (L \P**T * B) ] +* + CALL DLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL DLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 1 ), 1 ) + CALL DLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 2*N ), 1 ) + END IF + CALL DGTSV( N, NRHS, WORK( 1 ), WORK(N), WORK( 2*N ), B, LDB, + $ INFO) +* +* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ] +* + CALL DTRSM( 'L', 'L', 'T', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B( 2, 1 ), LDB) +* +* Pivot, P * B [ P * (L**T \ (T \ (L \P**T * B) )) ] +* + DO K = N, 1, -1 + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* + END IF +* + RETURN +* +* End of DSYTRS_AA +* + END diff --git a/math/lapack/src/main/fortran/dsytrs_rook.f b/math/lapack/src/main/fortran/dsytrs_rook.f new file mode 100644 index 0000000000..94a5e0042a --- /dev/null +++ b/math/lapack/src/main/fortran/dsytrs_rook.f @@ -0,0 +1,484 @@ +*> \brief \b DSYTRS_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRS_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRS_ROOK 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_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2012, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. 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_ROOK', -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**T. +* +* 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 and -IPIV(K) THEN K-1 and -IPIV(K-1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K-1 ) + 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. +* + IF( K.GT.2 ) THEN + 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 ) + END IF +* +* 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**T *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**T(K)), where U(K) is the transformation +* stored in column K of A. +* + IF( K.GT.1 ) + $ 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**T(K+1)), where U(K+1) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.GT.1 ) THEN + 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 ) + END IF +* +* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1). +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K+1 ) + IF( KP.NE.K+1 ) + $ CALL DSWAP( NRHS, B( K+1, 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**T. +* +* 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 and -IPIV(K) THEN K+1 and -IPIV(K+1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K+1 ) + 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**T *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**T(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**T(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) THEN K-1 and -IPIV(K-1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K-1 ) + IF( KP.NE.K-1 ) + $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) +* + K = K - 2 + END IF +* + GO TO 90 + 100 CONTINUE + END IF +* + RETURN +* +* End of DSYTRS_ROOK +* + END diff --git a/math/lapack/src/main/fortran/dtbcon.f b/math/lapack/src/main/fortran/dtbcon.f new file mode 100644 index 0000000000..ec0d3a15a1 --- /dev/null +++ b/math/lapack/src/main/fortran/dtbcon.f @@ -0,0 +1,284 @@ +*> \brief \b DTBCON +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTBCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, +* IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, NORM, UPLO +* INTEGER INFO, KD, LDAB, N +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTBCON estimates the reciprocal of the condition number of a +*> triangular band matrix A, in either the 1-norm or the infinity-norm. +*> +*> The norm of A is computed and an estimate is obtained for +*> norm(inv(A)), then the reciprocal of the condition number is +*> computed as +*> RCOND = 1 / ( norm(A) * norm(inv(A)) ). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is 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. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> = 'N': A is non-unit triangular; +*> = 'U': A is unit triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals or subdiagonals of the +*> triangular band matrix A. KD >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> The upper or lower triangular band matrix A, stored in the +*> first kd+1 rows of the array. The j-th column of A is stored +*> in the j-th column of the array AB as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> If DIAG = 'U', the diagonal elements of A are not referenced +*> and are assumed to be 1. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(norm(A) * norm(inv(A))). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, + $ IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, NORM, UPLO + INTEGER INFO, KD, LDAB, N + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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, DLANTB + EXTERNAL LSAME, IDAMAX, DLAMCH, DLANTB +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DLATBS, 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( KD.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTBCON', -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 = DLANTB( NORM, UPLO, DIAG, N, KD, AB, LDAB, 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 DLATBS( UPLO, 'No transpose', DIAG, NORMIN, N, KD, + $ AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO ) + ELSE +* +* Multiply by inv(A**T). +* + CALL DLATBS( UPLO, 'Transpose', DIAG, NORMIN, N, KD, AB, + $ LDAB, 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 DTBCON +* + END diff --git a/math/lapack/src/main/fortran/dtbrfs.f b/math/lapack/src/main/fortran/dtbrfs.f new file mode 100644 index 0000000000..05bfb7348f --- /dev/null +++ b/math/lapack/src/main/fortran/dtbrfs.f @@ -0,0 +1,485 @@ +*> \brief \b DTBRFS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTBRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, +* LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, TRANS, UPLO +* INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), BERR( * ), +* $ FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTBRFS provides error bounds and backward error estimates for the +*> solution to a system of linear equations with a triangular band +*> coefficient matrix. +*> +*> The solution matrix X must be computed by DTBTRS or some other +*> means before entering this routine. DTBRFS does not do iterative +*> refinement because doing so cannot improve the backward error. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> = 'N': A is non-unit triangular; +*> = 'U': A is unit triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals or subdiagonals of the +*> triangular band matrix A. KD >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> The upper or lower triangular band matrix A, stored in the +*> first kd+1 rows of the array. The j-th column of A is stored +*> in the j-th column of the array AB as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> If DIAG = 'U', the diagonal elements of A are not referenced +*> and are assumed to be 1. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> The solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, + $ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, TRANS, UPLO + INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), BERR( * ), + $ FERR( * ), WORK( * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN, NOUNIT, UPPER + CHARACTER TRANST + INTEGER I, J, K, KASE, NZ + DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLACN2, DTBMV, DTBSV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + NOTRAN = LSAME( TRANS, 'N' ) + NOUNIT = LSAME( DIAG, 'N' ) +* + 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( N.LT.0 ) THEN + INFO = -4 + ELSE IF( KD.LT.0 ) THEN + INFO = -5 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -8 + 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( 'DTBRFS', -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 = KD + 2 + EPS = DLAMCH( 'Epsilon' ) + SAFMIN = DLAMCH( 'Safe minimum' ) + SAFE1 = NZ*SAFMIN + SAFE2 = SAFE1 / EPS +* +* Do for each right hand side +* + DO 250 J = 1, NRHS +* +* Compute residual R = B - op(A) * X, +* where op(A) = A or A**T, depending on TRANS. +* + CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 ) + CALL DTBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK( N+1 ), + $ 1 ) + CALL DAXPY( N, -ONE, B( 1, J ), 1, 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 20 I = 1, N + WORK( I ) = ABS( B( I, J ) ) + 20 CONTINUE +* + IF( NOTRAN ) THEN +* +* Compute abs(A)*abs(X) + abs(B). +* + IF( UPPER ) THEN + IF( NOUNIT ) THEN + DO 40 K = 1, N + XK = ABS( X( K, J ) ) + DO 30 I = MAX( 1, K-KD ), K + WORK( I ) = WORK( I ) + + $ ABS( AB( KD+1+I-K, K ) )*XK + 30 CONTINUE + 40 CONTINUE + ELSE + DO 60 K = 1, N + XK = ABS( X( K, J ) ) + DO 50 I = MAX( 1, K-KD ), K - 1 + WORK( I ) = WORK( I ) + + $ ABS( AB( KD+1+I-K, K ) )*XK + 50 CONTINUE + WORK( K ) = WORK( K ) + XK + 60 CONTINUE + END IF + ELSE + IF( NOUNIT ) THEN + DO 80 K = 1, N + XK = ABS( X( K, J ) ) + DO 70 I = K, MIN( N, K+KD ) + WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK + 70 CONTINUE + 80 CONTINUE + ELSE + DO 100 K = 1, N + XK = ABS( X( K, J ) ) + DO 90 I = K + 1, MIN( N, K+KD ) + WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK + 90 CONTINUE + WORK( K ) = WORK( K ) + XK + 100 CONTINUE + END IF + END IF + ELSE +* +* Compute abs(A**T)*abs(X) + abs(B). +* + IF( UPPER ) THEN + IF( NOUNIT ) THEN + DO 120 K = 1, N + S = ZERO + DO 110 I = MAX( 1, K-KD ), K + S = S + ABS( AB( KD+1+I-K, K ) )* + $ ABS( X( I, J ) ) + 110 CONTINUE + WORK( K ) = WORK( K ) + S + 120 CONTINUE + ELSE + DO 140 K = 1, N + S = ABS( X( K, J ) ) + DO 130 I = MAX( 1, K-KD ), K - 1 + S = S + ABS( AB( KD+1+I-K, K ) )* + $ ABS( X( I, J ) ) + 130 CONTINUE + WORK( K ) = WORK( K ) + S + 140 CONTINUE + END IF + ELSE + IF( NOUNIT ) THEN + DO 160 K = 1, N + S = ZERO + DO 150 I = K, MIN( N, K+KD ) + S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) ) + 150 CONTINUE + WORK( K ) = WORK( K ) + S + 160 CONTINUE + ELSE + DO 180 K = 1, N + S = ABS( X( K, J ) ) + DO 170 I = K + 1, MIN( N, K+KD ) + S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) ) + 170 CONTINUE + WORK( K ) = WORK( K ) + S + 180 CONTINUE + END IF + END IF + END IF + S = ZERO + DO 190 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 + 190 CONTINUE + BERR( J ) = S +* +* Bound error from formula +* +* norm(X - XTRUE) / norm(X) .le. FERR = +* norm( abs(inv(op(A)))* +* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) +* +* where +* norm(Z) is the magnitude of the largest component of Z +* inv(op(A)) is the inverse of op(A) +* abs(Z) is the componentwise absolute value of the matrix or +* vector Z +* NZ is the maximum number of nonzeros in any row of A, plus 1 +* EPS is machine epsilon +* +* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) +* is incremented by SAFE1 if the i-th component of +* abs(op(A))*abs(X) + abs(B) is less than SAFE2. +* +* Use DLACN2 to estimate the infinity-norm of the matrix +* inv(op(A)) * diag(W), +* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) +* + DO 200 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 + 200 CONTINUE +* + KASE = 0 + 210 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 DTBSV( UPLO, TRANST, DIAG, N, KD, AB, LDAB, + $ WORK( N+1 ), 1 ) + DO 220 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 220 CONTINUE + ELSE +* +* Multiply by inv(op(A))*diag(W). +* + DO 230 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 230 CONTINUE + CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, + $ WORK( N+1 ), 1 ) + END IF + GO TO 210 + END IF +* +* Normalize error. +* + LSTRES = ZERO + DO 240 I = 1, N + LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) + 240 CONTINUE + IF( LSTRES.NE.ZERO ) + $ FERR( J ) = FERR( J ) / LSTRES +* + 250 CONTINUE +* + RETURN +* +* End of DTBRFS +* + END diff --git a/math/lapack/src/main/fortran/dtbtrs.f b/math/lapack/src/main/fortran/dtbtrs.f new file mode 100644 index 0000000000..e5fb876592 --- /dev/null +++ b/math/lapack/src/main/fortran/dtbtrs.f @@ -0,0 +1,244 @@ +*> \brief \b DTBTRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTBTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, +* LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, TRANS, UPLO +* INTEGER INFO, KD, LDAB, LDB, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTBTRS solves a triangular system of the form +*> +*> A * X = B or A**T * X = B, +*> +*> where A is a triangular band matrix of order N, and B is an +*> N-by NRHS matrix. A check is made to verify that A is nonsingular. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the form the system of equations: +*> = 'N': A * X = B (No transpose) +*> = 'T': A**T * X = B (Transpose) +*> = 'C': A**H * X = B (Conjugate transpose = Transpose) +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> = 'N': A is non-unit triangular; +*> = 'U': A is unit triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals or subdiagonals of the +*> triangular band matrix A. KD >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> The upper or lower triangular band matrix A, stored in the +*> first kd+1 rows of AB. The j-th column of A is stored +*> in the j-th column of the array AB as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> If DIAG = 'U', the diagonal elements of A are not referenced +*> and are assumed to be 1. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, if INFO = 0, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, + $ LDB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, TRANS, UPLO + INTEGER INFO, KD, LDAB, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT, UPPER + INTEGER J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DTBSV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NOUNIT = LSAME( DIAG, 'N' ) + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .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( KD.LT.0 ) THEN + INFO = -5 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTBTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Check for singularity. +* + IF( NOUNIT ) THEN + IF( UPPER ) THEN + DO 10 INFO = 1, N + IF( AB( KD+1, INFO ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + ELSE + DO 20 INFO = 1, N + IF( AB( 1, INFO ).EQ.ZERO ) + $ RETURN + 20 CONTINUE + END IF + END IF + INFO = 0 +* +* Solve A * X = B or A**T * X = B. +* + DO 30 J = 1, NRHS + CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, B( 1, J ), 1 ) + 30 CONTINUE +* + RETURN +* +* End of DTBTRS +* + END diff --git a/math/lapack/src/main/fortran/dtfsm.f b/math/lapack/src/main/fortran/dtfsm.f new file mode 100644 index 0000000000..515f6f5438 --- /dev/null +++ b/math/lapack/src/main/fortran/dtfsm.f @@ -0,0 +1,1006 @@ +*> \brief \b DTFSM solves a matrix equation (one operand is a triangular matrix in RFP format). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTFSM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, +* B, LDB ) +* +* .. Scalar Arguments .. +* CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO +* INTEGER LDB, M, N +* DOUBLE PRECISION ALPHA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( 0: * ), B( 0: LDB-1, 0: * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Level 3 BLAS like routine for A in RFP Format. +*> +*> DTFSM solves the matrix equation +*> +*> op( A )*X = alpha*B or X*op( A ) = alpha*B +*> +*> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +*> non-unit, upper or lower triangular matrix and op( A ) is one of +*> +*> op( A ) = A or op( A ) = A**T. +*> +*> A is in Rectangular Full Packed (RFP) Format. +*> +*> The matrix X is overwritten on B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSR +*> \verbatim +*> TRANSR is CHARACTER*1 +*> = 'N': The Normal Form of RFP A is stored; +*> = 'T': The Transpose Form of RFP A is stored. +*> \endverbatim +*> +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether op( A ) appears on the left +*> or right of X as follows: +*> +*> SIDE = 'L' or 'l' op( A )*X = alpha*B. +*> +*> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +*> +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the RFP matrix A came from +*> an upper or lower triangular matrix as follows: +*> UPLO = 'U' or 'u' RFP A came from an upper triangular matrix +*> UPLO = 'L' or 'l' RFP A came from a lower triangular matrix +*> +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the form of op( A ) to be used +*> in the matrix multiplication as follows: +*> +*> TRANS = 'N' or 'n' op( A ) = A. +*> +*> TRANS = 'T' or 't' op( A ) = A'. +*> +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not RFP A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of B. M must be at +*> least zero. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of B. N must be +*> at least zero. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> On entry, ALPHA specifies the scalar alpha. When alpha is +*> zero then A is not referenced and B need not be set before +*> entry. +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (NT) +*> NT = N*(N+1)/2. On entry, the matrix A in RFP Format. +*> RFP Format is described by TRANSR, UPLO and N as follows: +*> If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; +*> K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If +*> TRANSR = 'T' then RFP is the transpose of RFP A as +*> defined when TRANSR = 'N'. The contents of RFP A are defined +*> by UPLO as follows: If UPLO = 'U' the RFP A contains the NT +*> elements of upper packed A either in normal or +*> transpose Format. If UPLO = 'L' the RFP A contains +*> the NT elements of lower packed A either in normal or +*> transpose Format. The LDA of RFP A is (N+1)/2 when +*> TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is +*> even and is N when is odd. +*> See the Note below for more details. Unchanged on exit. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> Before entry, the leading m by n part of the array B must +*> contain the right-hand side matrix B, and on exit is +*> overwritten by the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> Unchanged on exit. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> We first consider Rectangular Full Packed (RFP) Format when N is +*> even. We give an example where N = 6. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 05 00 +*> 11 12 13 14 15 10 11 +*> 22 23 24 25 20 21 22 +*> 33 34 35 30 31 32 33 +*> 44 45 40 41 42 43 44 +*> 55 50 51 52 53 54 55 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(4:6,0:2) consists of +*> the transpose of the first three columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:2,0:2) consists of +*> the transpose of the last three columns of AP lower. +*> This covers the case N even and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 03 04 05 33 43 53 +*> 13 14 15 00 44 54 +*> 23 24 25 10 11 55 +*> 33 34 35 20 21 22 +*> 00 44 45 30 31 32 +*> 01 11 55 40 41 42 +*> 02 12 22 50 51 52 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> +*> RFP A RFP A +*> +*> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +*> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +*> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +*> +*> +*> We then consider Rectangular Full Packed (RFP) Format when N is +*> odd. We give an example where N = 5. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 00 +*> 11 12 13 14 10 11 +*> 22 23 24 20 21 22 +*> 33 34 30 31 32 33 +*> 44 40 41 42 43 44 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(3:4,0:1) consists of +*> the transpose of the first two columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:1,1:2) consists of +*> the transpose of the last two columns of AP lower. +*> This covers the case N odd and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 02 03 04 00 33 43 +*> 12 13 14 10 11 44 +*> 22 23 24 20 21 22 +*> 00 33 34 30 31 32 +*> 01 11 44 40 41 42 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> RFP A RFP A +*> +*> 02 12 22 00 01 00 10 20 30 40 50 +*> 03 13 23 33 11 33 11 21 31 41 51 +*> 04 14 24 34 44 43 44 22 32 42 52 +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, + $ B, LDB ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO + INTEGER LDB, M, N + DOUBLE PRECISION ALPHA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( 0: * ), B( 0: LDB-1, 0: * ) +* .. +* +* ===================================================================== +* +* .. +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LSIDE, MISODD, NISODD, NORMALTRANSR, + $ NOTRANS + INTEGER M1, M2, N1, N2, K, INFO, I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DGEMM, DTRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LSIDE = LSAME( SIDE, 'L' ) + LOWER = LSAME( UPLO, 'L' ) + NOTRANS = LSAME( TRANS, 'N' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSIDE .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -3 + ELSE IF( .NOT.NOTRANS .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -4 + ELSE IF( .NOT.LSAME( DIAG, 'N' ) .AND. .NOT.LSAME( DIAG, 'U' ) ) + $ THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( N.LT.0 ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTFSM ', -INFO ) + RETURN + END IF +* +* Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) +* + IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) + $ RETURN +* +* Quick return when ALPHA.EQ.(0D+0) +* + IF( ALPHA.EQ.ZERO ) THEN + DO 20 J = 0, N - 1 + DO 10 I = 0, M - 1 + B( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* + IF( LSIDE ) THEN +* +* SIDE = 'L' +* +* A is M-by-M. +* If M is odd, set NISODD = .TRUE., and M1 and M2. +* If M is even, NISODD = .FALSE., and M. +* + IF( MOD( M, 2 ).EQ.0 ) THEN + MISODD = .FALSE. + K = M / 2 + ELSE + MISODD = .TRUE. + IF( LOWER ) THEN + M2 = M / 2 + M1 = M - M2 + ELSE + M1 = M / 2 + M2 = M - M1 + END IF + END IF +* +* + IF( MISODD ) THEN +* +* SIDE = 'L' and N is odd +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'L', N is odd, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'N' +* + IF( M.EQ.1 ) THEN + CALL DTRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, + $ A, M, B, LDB ) + ELSE + CALL DTRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, + $ A( 0 ), M, B, LDB ) + CALL DGEMM( 'N', 'N', M2, N, M1, -ONE, A( M1 ), + $ M, B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL DTRSM( 'L', 'U', 'T', DIAG, M2, N, ONE, + $ A( M ), M, B( M1, 0 ), LDB ) + END IF +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'T' +* + IF( M.EQ.1 ) THEN + CALL DTRSM( 'L', 'L', 'T', DIAG, M1, N, ALPHA, + $ A( 0 ), M, B, LDB ) + ELSE + CALL DTRSM( 'L', 'U', 'N', DIAG, M2, N, ALPHA, + $ A( M ), M, B( M1, 0 ), LDB ) + CALL DGEMM( 'T', 'N', M1, N, M2, -ONE, A( M1 ), + $ M, B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL DTRSM( 'L', 'L', 'T', DIAG, M1, N, ONE, + $ A( 0 ), M, B, LDB ) + END IF +* + END IF +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'N' +* + CALL DTRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, + $ A( M2 ), M, B, LDB ) + CALL DGEMM( 'T', 'N', M2, N, M1, -ONE, A( 0 ), M, + $ B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL DTRSM( 'L', 'U', 'T', DIAG, M2, N, ONE, + $ A( M1 ), M, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'T' +* + CALL DTRSM( 'L', 'U', 'N', DIAG, M2, N, ALPHA, + $ A( M1 ), M, B( M1, 0 ), LDB ) + CALL DGEMM( 'N', 'N', M1, N, M2, -ONE, A( 0 ), M, + $ B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL DTRSM( 'L', 'L', 'T', DIAG, M1, N, ONE, + $ A( M2 ), M, B, LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'L', N is odd, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and +* TRANS = 'N' +* + IF( M.EQ.1 ) THEN + CALL DTRSM( 'L', 'U', 'T', DIAG, M1, N, ALPHA, + $ A( 0 ), M1, B, LDB ) + ELSE + CALL DTRSM( 'L', 'U', 'T', DIAG, M1, N, ALPHA, + $ A( 0 ), M1, B, LDB ) + CALL DGEMM( 'T', 'N', M2, N, M1, -ONE, + $ A( M1*M1 ), M1, B, LDB, ALPHA, + $ B( M1, 0 ), LDB ) + CALL DTRSM( 'L', 'L', 'N', DIAG, M2, N, ONE, + $ A( 1 ), M1, B( M1, 0 ), LDB ) + END IF +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and +* TRANS = 'T' +* + IF( M.EQ.1 ) THEN + CALL DTRSM( 'L', 'U', 'N', DIAG, M1, N, ALPHA, + $ A( 0 ), M1, B, LDB ) + ELSE + CALL DTRSM( 'L', 'L', 'T', DIAG, M2, N, ALPHA, + $ A( 1 ), M1, B( M1, 0 ), LDB ) + CALL DGEMM( 'N', 'N', M1, N, M2, -ONE, + $ A( M1*M1 ), M1, B( M1, 0 ), LDB, + $ ALPHA, B, LDB ) + CALL DTRSM( 'L', 'U', 'N', DIAG, M1, N, ONE, + $ A( 0 ), M1, B, LDB ) + END IF +* + END IF +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and +* TRANS = 'N' +* + CALL DTRSM( 'L', 'U', 'T', DIAG, M1, N, ALPHA, + $ A( M2*M2 ), M2, B, LDB ) + CALL DGEMM( 'N', 'N', M2, N, M1, -ONE, A( 0 ), M2, + $ B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL DTRSM( 'L', 'L', 'N', DIAG, M2, N, ONE, + $ A( M1*M2 ), M2, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and +* TRANS = 'T' +* + CALL DTRSM( 'L', 'L', 'T', DIAG, M2, N, ALPHA, + $ A( M1*M2 ), M2, B( M1, 0 ), LDB ) + CALL DGEMM( 'T', 'N', M1, N, M2, -ONE, A( 0 ), M2, + $ B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL DTRSM( 'L', 'U', 'N', DIAG, M1, N, ONE, + $ A( M2*M2 ), M2, B, LDB ) +* + END IF +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'L' and N is even +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'L', N is even, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'N' +* + CALL DTRSM( 'L', 'L', 'N', DIAG, K, N, ALPHA, + $ A( 1 ), M+1, B, LDB ) + CALL DGEMM( 'N', 'N', K, N, K, -ONE, A( K+1 ), + $ M+1, B, LDB, ALPHA, B( K, 0 ), LDB ) + CALL DTRSM( 'L', 'U', 'T', DIAG, K, N, ONE, + $ A( 0 ), M+1, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'T' +* + CALL DTRSM( 'L', 'U', 'N', DIAG, K, N, ALPHA, + $ A( 0 ), M+1, B( K, 0 ), LDB ) + CALL DGEMM( 'T', 'N', K, N, K, -ONE, A( K+1 ), + $ M+1, B( K, 0 ), LDB, ALPHA, B, LDB ) + CALL DTRSM( 'L', 'L', 'T', DIAG, K, N, ONE, + $ A( 1 ), M+1, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'N' +* + CALL DTRSM( 'L', 'L', 'N', DIAG, K, N, ALPHA, + $ A( K+1 ), M+1, B, LDB ) + CALL DGEMM( 'T', 'N', K, N, K, -ONE, A( 0 ), M+1, + $ B, LDB, ALPHA, B( K, 0 ), LDB ) + CALL DTRSM( 'L', 'U', 'T', DIAG, K, N, ONE, + $ A( K ), M+1, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'T' + CALL DTRSM( 'L', 'U', 'N', DIAG, K, N, ALPHA, + $ A( K ), M+1, B( K, 0 ), LDB ) + CALL DGEMM( 'N', 'N', K, N, K, -ONE, A( 0 ), M+1, + $ B( K, 0 ), LDB, ALPHA, B, LDB ) + CALL DTRSM( 'L', 'L', 'T', DIAG, K, N, ONE, + $ A( K+1 ), M+1, B, LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'L', N is even, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', +* and TRANS = 'N' +* + CALL DTRSM( 'L', 'U', 'T', DIAG, K, N, ALPHA, + $ A( K ), K, B, LDB ) + CALL DGEMM( 'T', 'N', K, N, K, -ONE, + $ A( K*( K+1 ) ), K, B, LDB, ALPHA, + $ B( K, 0 ), LDB ) + CALL DTRSM( 'L', 'L', 'N', DIAG, K, N, ONE, + $ A( 0 ), K, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', +* and TRANS = 'T' +* + CALL DTRSM( 'L', 'L', 'T', DIAG, K, N, ALPHA, + $ A( 0 ), K, B( K, 0 ), LDB ) + CALL DGEMM( 'N', 'N', K, N, K, -ONE, + $ A( K*( K+1 ) ), K, B( K, 0 ), LDB, + $ ALPHA, B, LDB ) + CALL DTRSM( 'L', 'U', 'N', DIAG, K, N, ONE, + $ A( K ), K, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', +* and TRANS = 'N' +* + CALL DTRSM( 'L', 'U', 'T', DIAG, K, N, ALPHA, + $ A( K*( K+1 ) ), K, B, LDB ) + CALL DGEMM( 'N', 'N', K, N, K, -ONE, A( 0 ), K, B, + $ LDB, ALPHA, B( K, 0 ), LDB ) + CALL DTRSM( 'L', 'L', 'N', DIAG, K, N, ONE, + $ A( K*K ), K, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', +* and TRANS = 'T' +* + CALL DTRSM( 'L', 'L', 'T', DIAG, K, N, ALPHA, + $ A( K*K ), K, B( K, 0 ), LDB ) + CALL DGEMM( 'T', 'N', K, N, K, -ONE, A( 0 ), K, + $ B( K, 0 ), LDB, ALPHA, B, LDB ) + CALL DTRSM( 'L', 'U', 'N', DIAG, K, N, ONE, + $ A( K*( K+1 ) ), K, B, LDB ) +* + END IF +* + END IF +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R' +* +* A is N-by-N. +* If N is odd, set NISODD = .TRUE., and N1 and N2. +* If N is even, NISODD = .FALSE., and K. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + NISODD = .FALSE. + K = N / 2 + ELSE + NISODD = .TRUE. + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF + END IF +* + IF( NISODD ) THEN +* +* SIDE = 'R' and N is odd +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'R', N is odd, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'N' +* + CALL DTRSM( 'R', 'U', 'T', DIAG, M, N2, ALPHA, + $ A( N ), N, B( 0, N1 ), LDB ) + CALL DGEMM( 'N', 'N', M, N1, N2, -ONE, B( 0, N1 ), + $ LDB, A( N1 ), N, ALPHA, B( 0, 0 ), + $ LDB ) + CALL DTRSM( 'R', 'L', 'N', DIAG, M, N1, ONE, + $ A( 0 ), N, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'T' +* + CALL DTRSM( 'R', 'L', 'T', DIAG, M, N1, ALPHA, + $ A( 0 ), N, B( 0, 0 ), LDB ) + CALL DGEMM( 'N', 'T', M, N2, N1, -ONE, B( 0, 0 ), + $ LDB, A( N1 ), N, ALPHA, B( 0, N1 ), + $ LDB ) + CALL DTRSM( 'R', 'U', 'N', DIAG, M, N2, ONE, + $ A( N ), N, B( 0, N1 ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'N' +* + CALL DTRSM( 'R', 'L', 'T', DIAG, M, N1, ALPHA, + $ A( N2 ), N, B( 0, 0 ), LDB ) + CALL DGEMM( 'N', 'N', M, N2, N1, -ONE, B( 0, 0 ), + $ LDB, A( 0 ), N, ALPHA, B( 0, N1 ), + $ LDB ) + CALL DTRSM( 'R', 'U', 'N', DIAG, M, N2, ONE, + $ A( N1 ), N, B( 0, N1 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'T' +* + CALL DTRSM( 'R', 'U', 'T', DIAG, M, N2, ALPHA, + $ A( N1 ), N, B( 0, N1 ), LDB ) + CALL DGEMM( 'N', 'T', M, N1, N2, -ONE, B( 0, N1 ), + $ LDB, A( 0 ), N, ALPHA, B( 0, 0 ), LDB ) + CALL DTRSM( 'R', 'L', 'N', DIAG, M, N1, ONE, + $ A( N2 ), N, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R', N is odd, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and +* TRANS = 'N' +* + CALL DTRSM( 'R', 'L', 'N', DIAG, M, N2, ALPHA, + $ A( 1 ), N1, B( 0, N1 ), LDB ) + CALL DGEMM( 'N', 'T', M, N1, N2, -ONE, B( 0, N1 ), + $ LDB, A( N1*N1 ), N1, ALPHA, B( 0, 0 ), + $ LDB ) + CALL DTRSM( 'R', 'U', 'T', DIAG, M, N1, ONE, + $ A( 0 ), N1, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and +* TRANS = 'T' +* + CALL DTRSM( 'R', 'U', 'N', DIAG, M, N1, ALPHA, + $ A( 0 ), N1, B( 0, 0 ), LDB ) + CALL DGEMM( 'N', 'N', M, N2, N1, -ONE, B( 0, 0 ), + $ LDB, A( N1*N1 ), N1, ALPHA, B( 0, N1 ), + $ LDB ) + CALL DTRSM( 'R', 'L', 'T', DIAG, M, N2, ONE, + $ A( 1 ), N1, B( 0, N1 ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and +* TRANS = 'N' +* + CALL DTRSM( 'R', 'U', 'N', DIAG, M, N1, ALPHA, + $ A( N2*N2 ), N2, B( 0, 0 ), LDB ) + CALL DGEMM( 'N', 'T', M, N2, N1, -ONE, B( 0, 0 ), + $ LDB, A( 0 ), N2, ALPHA, B( 0, N1 ), + $ LDB ) + CALL DTRSM( 'R', 'L', 'T', DIAG, M, N2, ONE, + $ A( N1*N2 ), N2, B( 0, N1 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and +* TRANS = 'T' +* + CALL DTRSM( 'R', 'L', 'N', DIAG, M, N2, ALPHA, + $ A( N1*N2 ), N2, B( 0, N1 ), LDB ) + CALL DGEMM( 'N', 'N', M, N1, N2, -ONE, B( 0, N1 ), + $ LDB, A( 0 ), N2, ALPHA, B( 0, 0 ), + $ LDB ) + CALL DTRSM( 'R', 'U', 'T', DIAG, M, N1, ONE, + $ A( N2*N2 ), N2, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R' and N is even +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'R', N is even, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'N' +* + CALL DTRSM( 'R', 'U', 'T', DIAG, M, K, ALPHA, + $ A( 0 ), N+1, B( 0, K ), LDB ) + CALL DGEMM( 'N', 'N', M, K, K, -ONE, B( 0, K ), + $ LDB, A( K+1 ), N+1, ALPHA, B( 0, 0 ), + $ LDB ) + CALL DTRSM( 'R', 'L', 'N', DIAG, M, K, ONE, + $ A( 1 ), N+1, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'T' +* + CALL DTRSM( 'R', 'L', 'T', DIAG, M, K, ALPHA, + $ A( 1 ), N+1, B( 0, 0 ), LDB ) + CALL DGEMM( 'N', 'T', M, K, K, -ONE, B( 0, 0 ), + $ LDB, A( K+1 ), N+1, ALPHA, B( 0, K ), + $ LDB ) + CALL DTRSM( 'R', 'U', 'N', DIAG, M, K, ONE, + $ A( 0 ), N+1, B( 0, K ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'N' +* + CALL DTRSM( 'R', 'L', 'T', DIAG, M, K, ALPHA, + $ A( K+1 ), N+1, B( 0, 0 ), LDB ) + CALL DGEMM( 'N', 'N', M, K, K, -ONE, B( 0, 0 ), + $ LDB, A( 0 ), N+1, ALPHA, B( 0, K ), + $ LDB ) + CALL DTRSM( 'R', 'U', 'N', DIAG, M, K, ONE, + $ A( K ), N+1, B( 0, K ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'T' +* + CALL DTRSM( 'R', 'U', 'T', DIAG, M, K, ALPHA, + $ A( K ), N+1, B( 0, K ), LDB ) + CALL DGEMM( 'N', 'T', M, K, K, -ONE, B( 0, K ), + $ LDB, A( 0 ), N+1, ALPHA, B( 0, 0 ), + $ LDB ) + CALL DTRSM( 'R', 'L', 'N', DIAG, M, K, ONE, + $ A( K+1 ), N+1, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R', N is even, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', +* and TRANS = 'N' +* + CALL DTRSM( 'R', 'L', 'N', DIAG, M, K, ALPHA, + $ A( 0 ), K, B( 0, K ), LDB ) + CALL DGEMM( 'N', 'T', M, K, K, -ONE, B( 0, K ), + $ LDB, A( ( K+1 )*K ), K, ALPHA, + $ B( 0, 0 ), LDB ) + CALL DTRSM( 'R', 'U', 'T', DIAG, M, K, ONE, + $ A( K ), K, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', +* and TRANS = 'T' +* + CALL DTRSM( 'R', 'U', 'N', DIAG, M, K, ALPHA, + $ A( K ), K, B( 0, 0 ), LDB ) + CALL DGEMM( 'N', 'N', M, K, K, -ONE, B( 0, 0 ), + $ LDB, A( ( K+1 )*K ), K, ALPHA, + $ B( 0, K ), LDB ) + CALL DTRSM( 'R', 'L', 'T', DIAG, M, K, ONE, + $ A( 0 ), K, B( 0, K ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', +* and TRANS = 'N' +* + CALL DTRSM( 'R', 'U', 'N', DIAG, M, K, ALPHA, + $ A( ( K+1 )*K ), K, B( 0, 0 ), LDB ) + CALL DGEMM( 'N', 'T', M, K, K, -ONE, B( 0, 0 ), + $ LDB, A( 0 ), K, ALPHA, B( 0, K ), LDB ) + CALL DTRSM( 'R', 'L', 'T', DIAG, M, K, ONE, + $ A( K*K ), K, B( 0, K ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', +* and TRANS = 'T' +* + CALL DTRSM( 'R', 'L', 'N', DIAG, M, K, ALPHA, + $ A( K*K ), K, B( 0, K ), LDB ) + CALL DGEMM( 'N', 'N', M, K, K, -ONE, B( 0, K ), + $ LDB, A( 0 ), K, ALPHA, B( 0, 0 ), LDB ) + CALL DTRSM( 'R', 'U', 'T', DIAG, M, K, ONE, + $ A( ( K+1 )*K ), K, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + END IF +* + END IF + END IF +* + RETURN +* +* End of DTFSM +* + END diff --git a/math/lapack/src/main/fortran/dtftri.f b/math/lapack/src/main/fortran/dtftri.f new file mode 100644 index 0000000000..9debec9702 --- /dev/null +++ b/math/lapack/src/main/fortran/dtftri.f @@ -0,0 +1,472 @@ +*> \brief \b DTFTRI +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTFTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANSR, UPLO, DIAG +* INTEGER INFO, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( 0: * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTFTRI computes the inverse of a triangular matrix A stored in RFP +*> format. +*> +*> This is a Level 3 BLAS version of the algorithm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSR +*> \verbatim +*> TRANSR is CHARACTER*1 +*> = 'N': The Normal TRANSR of RFP A is stored; +*> = 'T': The Transpose TRANSR of RFP A is stored. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> = 'N': A is non-unit triangular; +*> = 'U': A is unit triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (0:nt-1); +*> nt=N*(N+1)/2. On entry, the triangular factor of a Hermitian +*> Positive Definite matrix A in RFP format. RFP format is +*> described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' +*> then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is +*> (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is +*> the transpose of RFP A as defined when +*> TRANSR = 'N'. The contents of RFP A are defined by UPLO as +*> follows: If UPLO = 'U' the RFP A contains the nt elements of +*> upper packed A; If UPLO = 'L' the RFP A contains the nt +*> elements of lower packed A. The LDA of RFP A is (N+1)/2 when +*> TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is +*> even and N is odd. See the Note below for more details. +*> +*> On exit, the (triangular) inverse of the original matrix, in +*> the same storage format. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, A(i,i) is exactly zero. The triangular +*> matrix is singular and its inverse can not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> We first consider Rectangular Full Packed (RFP) Format when N is +*> even. We give an example where N = 6. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 05 00 +*> 11 12 13 14 15 10 11 +*> 22 23 24 25 20 21 22 +*> 33 34 35 30 31 32 33 +*> 44 45 40 41 42 43 44 +*> 55 50 51 52 53 54 55 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(4:6,0:2) consists of +*> the transpose of the first three columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:2,0:2) consists of +*> the transpose of the last three columns of AP lower. +*> This covers the case N even and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 03 04 05 33 43 53 +*> 13 14 15 00 44 54 +*> 23 24 25 10 11 55 +*> 33 34 35 20 21 22 +*> 00 44 45 30 31 32 +*> 01 11 55 40 41 42 +*> 02 12 22 50 51 52 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> +*> RFP A RFP A +*> +*> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +*> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +*> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +*> +*> +*> We then consider Rectangular Full Packed (RFP) Format when N is +*> odd. We give an example where N = 5. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 00 +*> 11 12 13 14 10 11 +*> 22 23 24 20 21 22 +*> 33 34 30 31 32 33 +*> 44 40 41 42 43 44 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(3:4,0:1) consists of +*> the transpose of the first two columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:1,1:2) consists of +*> the transpose of the last two columns of AP lower. +*> This covers the case N odd and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 02 03 04 00 33 43 +*> 12 13 14 10 11 44 +*> 22 23 24 20 21 22 +*> 00 33 34 30 31 32 +*> 01 11 44 40 41 42 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> RFP A RFP A +*> +*> 02 12 22 00 01 00 10 20 30 40 50 +*> 03 13 23 33 11 33 11 21 31 41 51 +*> 04 14 24 34 44 43 44 22 32 42 52 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO, DIAG + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( 0: * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DTRMM, DTRTRI +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LSAME( DIAG, 'N' ) .AND. .NOT.LSAME( DIAG, 'U' ) ) + $ THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTFTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + ELSE + NISODD = .TRUE. + END IF +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1) +* + CALL DTRTRI( 'L', DIAG, N1, A( 0 ), N, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CALL DTRMM( 'R', 'L', 'N', DIAG, N2, N1, -ONE, A( 0 ), + $ N, A( N1 ), N ) + CALL DTRTRI( 'U', DIAG, N2, A( N ), N, INFO ) + IF( INFO.GT.0 ) + $ INFO = INFO + N1 + IF( INFO.GT.0 ) + $ RETURN + CALL DTRMM( 'L', 'U', 'T', DIAG, N2, N1, ONE, A( N ), N, + $ A( N1 ), N ) +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + CALL DTRTRI( 'L', DIAG, N1, A( N2 ), N, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CALL DTRMM( 'L', 'L', 'T', DIAG, N1, N2, -ONE, A( N2 ), + $ N, A( 0 ), N ) + CALL DTRTRI( 'U', DIAG, N2, A( N1 ), N, INFO ) + IF( INFO.GT.0 ) + $ INFO = INFO + N1 + IF( INFO.GT.0 ) + $ RETURN + CALL DTRMM( 'R', 'U', 'N', DIAG, N1, N2, ONE, A( N1 ), + $ N, A( 0 ), N ) +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1) +* + CALL DTRTRI( 'U', DIAG, N1, A( 0 ), N1, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CALL DTRMM( 'L', 'U', 'N', DIAG, N1, N2, -ONE, A( 0 ), + $ N1, A( N1*N1 ), N1 ) + CALL DTRTRI( 'L', DIAG, N2, A( 1 ), N1, INFO ) + IF( INFO.GT.0 ) + $ INFO = INFO + N1 + IF( INFO.GT.0 ) + $ RETURN + CALL DTRMM( 'R', 'L', 'T', DIAG, N1, N2, ONE, A( 1 ), + $ N1, A( N1*N1 ), N1 ) +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) +* + CALL DTRTRI( 'U', DIAG, N1, A( N2*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CALL DTRMM( 'R', 'U', 'T', DIAG, N2, N1, -ONE, + $ A( N2*N2 ), N2, A( 0 ), N2 ) + CALL DTRTRI( 'L', DIAG, N2, A( N1*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + $ INFO = INFO + N1 + IF( INFO.GT.0 ) + $ RETURN + CALL DTRMM( 'L', 'L', 'N', DIAG, N2, N1, ONE, + $ A( N1*N2 ), N2, A( 0 ), N2 ) + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + CALL DTRTRI( 'L', DIAG, K, A( 1 ), N+1, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CALL DTRMM( 'R', 'L', 'N', DIAG, K, K, -ONE, A( 1 ), + $ N+1, A( K+1 ), N+1 ) + CALL DTRTRI( 'U', DIAG, K, A( 0 ), N+1, INFO ) + IF( INFO.GT.0 ) + $ INFO = INFO + K + IF( INFO.GT.0 ) + $ RETURN + CALL DTRMM( 'L', 'U', 'T', DIAG, K, K, ONE, A( 0 ), N+1, + $ A( K+1 ), N+1 ) +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + CALL DTRTRI( 'L', DIAG, K, A( K+1 ), N+1, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CALL DTRMM( 'L', 'L', 'T', DIAG, K, K, -ONE, A( K+1 ), + $ N+1, A( 0 ), N+1 ) + CALL DTRTRI( 'U', DIAG, K, A( K ), N+1, INFO ) + IF( INFO.GT.0 ) + $ INFO = INFO + K + IF( INFO.GT.0 ) + $ RETURN + CALL DTRMM( 'R', 'U', 'N', DIAG, K, K, ONE, A( K ), N+1, + $ A( 0 ), N+1 ) + END IF + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + CALL DTRTRI( 'U', DIAG, K, A( K ), K, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CALL DTRMM( 'L', 'U', 'N', DIAG, K, K, -ONE, A( K ), K, + $ A( K*( K+1 ) ), K ) + CALL DTRTRI( 'L', DIAG, K, A( 0 ), K, INFO ) + IF( INFO.GT.0 ) + $ INFO = INFO + K + IF( INFO.GT.0 ) + $ RETURN + CALL DTRMM( 'R', 'L', 'T', DIAG, K, K, ONE, A( 0 ), K, + $ A( K*( K+1 ) ), K ) + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + CALL DTRTRI( 'U', DIAG, K, A( K*( K+1 ) ), K, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CALL DTRMM( 'R', 'U', 'T', DIAG, K, K, -ONE, + $ A( K*( K+1 ) ), K, A( 0 ), K ) + CALL DTRTRI( 'L', DIAG, K, A( K*K ), K, INFO ) + IF( INFO.GT.0 ) + $ INFO = INFO + K + IF( INFO.GT.0 ) + $ RETURN + CALL DTRMM( 'L', 'L', 'N', DIAG, K, K, ONE, A( K*K ), K, + $ A( 0 ), K ) + END IF + END IF + END IF +* + RETURN +* +* End of DTFTRI +* + END diff --git a/math/lapack/src/main/fortran/dtfttp.f b/math/lapack/src/main/fortran/dtfttp.f new file mode 100644 index 0000000000..c2929824af --- /dev/null +++ b/math/lapack/src/main/fortran/dtfttp.f @@ -0,0 +1,517 @@ +*> \brief \b DTFTTP copies a triangular matrix from the rectangular full packed format (TF) to the standard packed format (TP). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTFTTP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANSR, UPLO +* INTEGER INFO, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( 0: * ), ARF( 0: * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTFTTP copies a triangular matrix A from rectangular full packed +*> format (TF) to standard packed format (TP). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSR +*> \verbatim +*> TRANSR is CHARACTER*1 +*> = 'N': ARF is in Normal format; +*> = 'T': ARF is in Transpose format; +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] ARF +*> \verbatim +*> ARF is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), +*> On entry, the upper or lower triangular matrix A stored in +*> RFP format. For a further discussion see Notes below. +*> \endverbatim +*> +*> \param[out] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), +*> On exit, the upper or lower triangular matrix A, packed +*> columnwise in a linear array. The j-th column of A is stored +*> in the array AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> We first consider Rectangular Full Packed (RFP) Format when N is +*> even. We give an example where N = 6. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 05 00 +*> 11 12 13 14 15 10 11 +*> 22 23 24 25 20 21 22 +*> 33 34 35 30 31 32 33 +*> 44 45 40 41 42 43 44 +*> 55 50 51 52 53 54 55 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(4:6,0:2) consists of +*> the transpose of the first three columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:2,0:2) consists of +*> the transpose of the last three columns of AP lower. +*> This covers the case N even and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 03 04 05 33 43 53 +*> 13 14 15 00 44 54 +*> 23 24 25 10 11 55 +*> 33 34 35 20 21 22 +*> 00 44 45 30 31 32 +*> 01 11 55 40 41 42 +*> 02 12 22 50 51 52 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> +*> RFP A RFP A +*> +*> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +*> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +*> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +*> +*> +*> We then consider Rectangular Full Packed (RFP) Format when N is +*> odd. We give an example where N = 5. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 00 +*> 11 12 13 14 10 11 +*> 22 23 24 20 21 22 +*> 33 34 30 31 32 33 +*> 44 40 41 42 43 44 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(3:4,0:1) consists of +*> the transpose of the first two columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:1,1:2) consists of +*> the transpose of the last two columns of AP lower. +*> This covers the case N odd and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 02 03 04 00 33 43 +*> 12 13 14 10 11 44 +*> 22 23 24 20 21 22 +*> 00 33 34 30 31 32 +*> 01 11 44 40 41 42 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> RFP A RFP A +*> +*> 02 12 22 00 01 00 10 20 30 40 50 +*> 03 13 23 33 11 33 11 21 31 41 51 +*> 04 14 24 34 44 43 44 22 32 42 52 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( 0: * ), ARF( 0: * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K, NT + INTEGER I, J, IJ + INTEGER IJP, JP, LDA, JS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTFTTP', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( NORMALTRANSR ) THEN + AP( 0 ) = ARF( 0 ) + ELSE + AP( 0 ) = ARF( 0 ) + END IF + RETURN + END IF +* +* Size of array ARF(0:NT-1) +* + NT = N*( N+1 ) / 2 +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* +* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) +* where noe = 0 if n is even, noe = 1 if n is odd +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + LDA = N + 1 + ELSE + NISODD = .TRUE. + LDA = N + END IF +* +* ARF^C has lda rows and n+1-noe cols +* + IF( .NOT.NORMALTRANSR ) + $ LDA = ( N+1 ) / 2 +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n +* + IJP = 0 + JP = 0 + DO J = 0, N2 + DO I = J, N - 1 + IJ = I + JP + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, N2 - 1 + DO J = 1 + I, N2 + IJ = I + J*LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + IJP = 0 + DO J = 0, N1 - 1 + IJ = N2 + J + DO I = 0, J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = N1, N - 1 + IJ = JS + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) +* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 +* + IJP = 0 + DO I = 0, N2 + DO IJ = I*( LDA+1 ), N*LDA - 1, LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO + JS = 1 + DO J = 0, N2 - 1 + DO IJ = JS, JS + N2 - J - 1 + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) +* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 +* + IJP = 0 + JS = N2*LDA + DO J = 0, N1 - 1 + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, N1 + DO IJ = I, I + ( N1+I )*LDA, LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + IJP = 0 + JP = 0 + DO J = 0, K - 1 + DO I = J, N - 1 + IJ = 1 + I + JP + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, K - 1 + DO J = I, K - 1 + IJ = I + J*LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + IJP = 0 + DO J = 0, K - 1 + IJ = K + 1 + J + DO I = 0, J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = K, N - 1 + IJ = JS + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + IJP = 0 + DO I = 0, K - 1 + DO IJ = I + ( I+1 )*LDA, ( N+1 )*LDA - 1, LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO + JS = 0 + DO J = 0, K - 1 + DO IJ = JS, JS + K - J - 1 + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + IJP = 0 + JS = ( K+1 )*LDA + DO J = 0, K - 1 + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, K - 1 + DO IJ = I, I + ( K+I )*LDA, LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of DTFTTP +* + END diff --git a/math/lapack/src/main/fortran/dtfttr.f b/math/lapack/src/main/fortran/dtfttr.f new file mode 100644 index 0000000000..bb1c6224f5 --- /dev/null +++ b/math/lapack/src/main/fortran/dtfttr.f @@ -0,0 +1,495 @@ +*> \brief \b DTFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full format (TR). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTFTTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANSR, UPLO +* INTEGER INFO, N, LDA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( 0: LDA-1, 0: * ), ARF( 0: * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTFTTR copies a triangular matrix A from rectangular full packed +*> format (TF) to standard full format (TR). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSR +*> \verbatim +*> TRANSR is CHARACTER*1 +*> = 'N': ARF is in Normal format; +*> = 'T': ARF is in Transpose format. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices ARF and A. N >= 0. +*> \endverbatim +*> +*> \param[in] ARF +*> \verbatim +*> ARF is DOUBLE PRECISION array, dimension (N*(N+1)/2). +*> On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') +*> matrix A in RFP format. See the "Notes" below for more +*> details. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On exit, the triangular matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of the array A contains +*> the upper triangular matrix, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of the array A contains +*> the lower triangular matrix, and the strictly upper +*> triangular part of A is not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> We first consider Rectangular Full Packed (RFP) Format when N is +*> even. We give an example where N = 6. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 05 00 +*> 11 12 13 14 15 10 11 +*> 22 23 24 25 20 21 22 +*> 33 34 35 30 31 32 33 +*> 44 45 40 41 42 43 44 +*> 55 50 51 52 53 54 55 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(4:6,0:2) consists of +*> the transpose of the first three columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:2,0:2) consists of +*> the transpose of the last three columns of AP lower. +*> This covers the case N even and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 03 04 05 33 43 53 +*> 13 14 15 00 44 54 +*> 23 24 25 10 11 55 +*> 33 34 35 20 21 22 +*> 00 44 45 30 31 32 +*> 01 11 55 40 41 42 +*> 02 12 22 50 51 52 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> +*> RFP A RFP A +*> +*> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +*> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +*> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +*> +*> +*> We then consider Rectangular Full Packed (RFP) Format when N is +*> odd. We give an example where N = 5. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 00 +*> 11 12 13 14 10 11 +*> 22 23 24 20 21 22 +*> 33 34 30 31 32 33 +*> 44 40 41 42 43 44 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(3:4,0:1) consists of +*> the transpose of the first two columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:1,1:2) consists of +*> the transpose of the last two columns of AP lower. +*> This covers the case N odd and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 02 03 04 00 33 43 +*> 12 13 14 10 11 44 +*> 22 23 24 20 21 22 +*> 00 33 34 30 31 32 +*> 01 11 44 40 41 42 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> RFP A RFP A +*> +*> 02 12 22 00 01 00 10 20 30 40 50 +*> 03 13 23 33 11 33 11 21 31 41 51 +*> 04 14 24 34 44 43 44 22 32 42 52 +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( 0: LDA-1, 0: * ), ARF( 0: * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K, NT, NX2, NP1X2 + INTEGER I, J, L, IJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTFTTR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) THEN + IF( N.EQ.1 ) THEN + A( 0, 0 ) = ARF( 0 ) + END IF + RETURN + END IF +* +* Size of array ARF(0:nt-1) +* + NT = N*( N+1 ) / 2 +* +* set N1 and N2 depending on LOWER: for N even N1=N2=K +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. +* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is +* N--by--(N+1)/2. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + IF( .NOT.LOWER ) + $ NP1X2 = N + N + 2 + ELSE + NISODD = .TRUE. + IF( .NOT.LOWER ) + $ NX2 = N + N + END IF +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'N', and UPLO = 'L' +* + IJ = 0 + DO J = 0, N2 + DO I = N1, N2 + J + A( N2+J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is odd, TRANSR = 'N', and UPLO = 'U' +* + IJ = NT - N + DO J = N - 1, N1, -1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = J - N1, N1 - 1 + A( J-N1, L ) = ARF( IJ ) + IJ = IJ + 1 + END DO + IJ = IJ - NX2 + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'T', and UPLO = 'L' +* + IJ = 0 + DO J = 0, N2 - 1 + DO I = 0, J + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO I = N1 + J, N - 1 + A( I, N1+J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO + DO J = N2, N - 1 + DO I = 0, N1 - 1 + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is odd, TRANSR = 'T', and UPLO = 'U' +* + IJ = 0 + DO J = 0, N1 + DO I = N1, N - 1 + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, N1 - 1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = N2 + J, N - 1 + A( N2+J, L ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'N', and UPLO = 'L' +* + IJ = 0 + DO J = 0, K - 1 + DO I = K, K + J + A( K+J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is even, TRANSR = 'N', and UPLO = 'U' +* + IJ = NT - N - 1 + DO J = N - 1, K, -1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = J - K, K - 1 + A( J-K, L ) = ARF( IJ ) + IJ = IJ + 1 + END DO + IJ = IJ - NP1X2 + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'T', and UPLO = 'L' +* + IJ = 0 + J = K + DO I = K, N - 1 + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO J = 0, K - 2 + DO I = 0, J + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO I = K + 1 + J, N - 1 + A( I, K+1+J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO + DO J = K - 1, N - 1 + DO I = 0, K - 1 + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is even, TRANSR = 'T', and UPLO = 'U' +* + IJ = 0 + DO J = 0, K + DO I = K, N - 1 + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, K - 2 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = K + 1 + J, N - 1 + A( K+1+J, L ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* Note that here, on exit of the loop, J = K-1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of DTFTTR +* + END diff --git a/math/lapack/src/main/fortran/dtgevc.f b/math/lapack/src/main/fortran/dtgevc.f new file mode 100644 index 0000000000..756474c9e0 --- /dev/null +++ b/math/lapack/src/main/fortran/dtgevc.f @@ -0,0 +1,1211 @@ +*> \brief \b DTGEVC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTGEVC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, +* LDVL, VR, LDVR, MM, M, WORK, INFO ) +* +* .. 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( * ) +* .. +* +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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). +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'R': compute right eigenvectors only; +*> = 'L': compute left eigenvectors only; +*> = 'B': compute both right and left eigenvectors. +*> \endverbatim +*> +*> \param[in] HOWMNY +*> \verbatim +*> HOWMNY is 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. +*> \endverbatim +*> +*> \param[in] SELECT +*> \verbatim +*> SELECT is 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'. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices S and P. N >= 0. +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (LDS,N) +*> The upper quasi-triangular matrix S from a generalized Schur +*> factorization, as computed by DHGEQZ. +*> \endverbatim +*> +*> \param[in] LDS +*> \verbatim +*> LDS is INTEGER +*> The leading dimension of array S. LDS >= max(1,N). +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is 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. +*> \endverbatim +*> +*> \param[in] LDP +*> \verbatim +*> LDP is INTEGER +*> The leading dimension of array P. LDP >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is 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'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of array VL. LDVL >= 1, and if +*> SIDE = 'L' or 'B', LDVL >= N. +*> \endverbatim +*> +*> \param[in,out] VR +*> \verbatim +*> VR is 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'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. LDVR >= 1, and if +*> SIDE = 'R' or 'B', LDVR >= N. +*> \endverbatim +*> +*> \param[in] MM +*> \verbatim +*> MM is INTEGER +*> The number of columns in the arrays VL and/or VR. MM >= M. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is 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. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (6*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, + $ LDVL, VR, LDVR, MM, M, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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( * ) +* .. +* +* +* ===================================================================== +* +* .. 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.) +* +* + DO 120 JW = 1, NW + 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 +* + 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/math/lapack/src/main/fortran/dtgex2.f b/math/lapack/src/main/fortran/dtgex2.f new file mode 100644 index 0000000000..93ff03acf6 --- /dev/null +++ b/math/lapack/src/main/fortran/dtgex2.f @@ -0,0 +1,697 @@ +*> \brief \b DTGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an orthogonal equivalence transformation. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTGEX2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, +* LDZ, J1, N1, N2, WORK, LWORK, INFO ) +* +* .. 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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)**T = Q(out) * A(out) * Z(out)**T +*> Q(in) * B(in) * Z(in)**T = Q(out) * B(out) * Z(out)**T +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTQ +*> \verbatim +*> WANTQ is LOGICAL +*> .TRUE. : update the left transformation matrix Q; +*> .FALSE.: do not update Q. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> .TRUE. : update the right transformation matrix Z; +*> .FALSE.: do not update Z. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimensions (LDA,N) +*> On entry, the matrix A in the pair (A, B). +*> On exit, the updated matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimensions (LDB,N) +*> On entry, the matrix B in the pair (A, B). +*> On exit, the updated matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ,N) +*> On entry, if WANTQ = .TRUE., the orthogonal matrix Q. +*> On exit, the updated matrix Q. +*> Not referenced if WANTQ = .FALSE.. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= 1. +*> If WANTQ = .TRUE., LDQ >= N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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.. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1. +*> If WANTZ = .TRUE., LDZ >= N. +*> \endverbatim +*> +*> \param[in] J1 +*> \verbatim +*> J1 is INTEGER +*> The index to the first block (A11, B11). 1 <= J1 <= N. +*> \endverbatim +*> +*> \param[in] N1 +*> \verbatim +*> N1 is INTEGER +*> The order of the first block (A11, B11). N1 = 0, 1 or 2. +*> \endverbatim +*> +*> \param[in] N2 +*> \verbatim +*> N2 is INTEGER +*> The order of the second block (A22, B22). N2 = 0, 1 or 2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)). +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> LWORK >= MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 ) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEauxiliary +* +*> \par Further Details: +* ===================== +*> +*> 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. +* +*> \par Contributors: +* ================== +*> +*> Bo Kagstrom and Peter Poromaa, Department of Computing Science, +*> Umea University, S-901 87 Umea, Sweden. +* +*> \par References: +* ================ +*> +*> \verbatim +*> +*> [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. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, + $ LDZ, J1, N1, N2, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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, * ) +* .. +* +* ===================================================================== +* 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 TWENTY + PARAMETER ( TWENTY = 2.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 ) +* +* THRES has been changed from +* THRESH = MAX( TEN*EPS*SA, SMLNUM ) +* to +* THRESH = MAX( TWENTY*EPS*SA, SMLNUM ) +* on 04/01/10. +* "Bug" reported by Ondra Kamenik, confirmed by Julie Langou, fixed by +* Jim Demmel and Guillaume Revy. See forum post 1783. +* + THRESH = MAX( TWENTY*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**T*S*QR, B-QL**T*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**T * 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**T = [ 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**T, B-QL*T*QR**T)) <= 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. +* + CALL DLASET( 'Full', M, M, ZERO, ZERO, WORK, M ) + 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 ), LDB, 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/math/lapack/src/main/fortran/dtgexc.f b/math/lapack/src/main/fortran/dtgexc.f new file mode 100644 index 0000000000..0a905b8db3 --- /dev/null +++ b/math/lapack/src/main/fortran/dtgexc.f @@ -0,0 +1,544 @@ +*> \brief \b DTGEXC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTGEXC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, +* LDZ, IFST, ILST, WORK, LWORK, INFO ) +* +* .. 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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**T, +*> +*> 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)**T = Q(out) * A(out) * Z(out)**T +*> Q(in) * B(in) * Z(in)**T = Q(out) * B(out) * Z(out)**T +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTQ +*> \verbatim +*> WANTQ is LOGICAL +*> .TRUE. : update the left transformation matrix Q; +*> .FALSE.: do not update Q. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> .TRUE. : update the right transformation matrix Z; +*> .FALSE.: do not update Z. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is 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). +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ,N) +*> On entry, if WANTQ = .TRUE., the orthogonal matrix Q. +*> On exit, the updated matrix Q. +*> If WANTQ = .FALSE., Q is not referenced. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= 1. +*> If WANTQ = .TRUE., LDQ >= N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1. +*> If WANTZ = .TRUE., LDZ >= N. +*> \endverbatim +*> +*> \param[in,out] IFST +*> \verbatim +*> IFST is INTEGER +*> \endverbatim +*> +*> \param[in,out] ILST +*> \verbatim +*> ILST is 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. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> LWORK >= 1 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Contributors: +* ================== +*> +*> Bo Kagstrom and Peter Poromaa, Department of Computing Science, +*> Umea University, S-901 87 Umea, Sweden. +* +*> \par References: +* ================ +*> +*> \verbatim +*> +*> [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. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, + $ LDZ, IFST, ILST, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dtgsen.f b/math/lapack/src/main/fortran/dtgsen.f new file mode 100644 index 0000000000..9f49239344 --- /dev/null +++ b/math/lapack/src/main/fortran/dtgsen.f @@ -0,0 +1,866 @@ +*> \brief \b DTGSEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTGSEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* 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 ) +* +* .. 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTGSEN reorders the generalized real Schur decomposition of a real +*> matrix pair (A, B) (in terms of an orthonormal equivalence trans- +*> formation Q**T * (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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] IJOB +*> \verbatim +*> IJOB is 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) +*> \endverbatim +*> +*> \param[in] WANTQ +*> \verbatim +*> WANTQ is LOGICAL +*> .TRUE. : update the left transformation matrix Q; +*> .FALSE.: do not update Q. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> .TRUE. : update the right transformation matrix Z; +*> .FALSE.: do not update Z. +*> \endverbatim +*> +*> \param[in] SELECT +*> \verbatim +*> SELECT is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is 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. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is 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. +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is 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. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= 1; +*> and if WANTQ = .TRUE., LDQ >= N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1; +*> If WANTZ = .TRUE., LDZ >= N. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The dimension of the specified pair of left and right eigen- +*> spaces (deflating subspaces). 0 <= M <= N. +*> \endverbatim +*> +*> \param[out] PL +*> \verbatim +*> PL is DOUBLE PRECISION +*> \endverbatim + +*> \param[out] PR +*> \verbatim +*> PR is 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. +*> \endverbatim +*> +*> \param[out] DIF +*> \verbatim +*> DIF is 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. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, +*> dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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**T*(A, B)*W = (A11 A12) (B11 B12) n1 +*> ( 0 A22),( 0 B22) n2 +*> n1 n2 n1 n2 +*> +*> where N = n1+n2 and U**T 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**T, then the +*> reordered generalized real Schur form of (C, D) is given by +*> +*> (C, D) = (Q*U)*(U**T*(A, B)*W)*(Z*W)**T, +*> +*> 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**T, In1) ] +*> [ kron(In2, B11) -kron(B22**T, In1) ]. +*> +*> Here, Inx is the identity matrix of size nx and A22**T 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. +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> Bo Kagstrom and Peter Poromaa, Department of Computing Science, +*> Umea University, S-901 87 Umea, Sweden. +* +*> \par References: +* ================ +*> +*> \verbatim +*> +*> [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. +*> \endverbatim +*> +* ===================================================================== + 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 computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. 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, * ) +* .. +* +* ===================================================================== +* +* .. 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. + IF( .NOT.LQUERY .OR. IJOB.NE.0 ) THEN + 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 + END IF +* + 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 ) + IF( WANTQ ) 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/math/lapack/src/main/fortran/dtgsja.f b/math/lapack/src/main/fortran/dtgsja.f new file mode 100644 index 0000000000..66f32b7909 --- /dev/null +++ b/math/lapack/src/main/fortran/dtgsja.f @@ -0,0 +1,655 @@ +*> \brief \b DTGSJA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTGSJA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, +* LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, +* Q, LDQ, WORK, NCYCLE, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBQ, JOBU, JOBV +* INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, +* $ NCYCLE, P +* DOUBLE PRECISION TOLA, TOLB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), ALPHA( * ), B( LDB, * ), +* $ BETA( * ), Q( LDQ, * ), U( LDU, * ), +* $ V( LDV, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTGSJA computes the generalized singular value decomposition (GSVD) +*> of two real upper triangular (or trapezoidal) matrices A and B. +*> +*> On entry, it is assumed that matrices A and B have the following +*> forms, which may be obtained by the preprocessing subroutine DGGSVP +*> from a general M-by-N matrix A and P-by-N matrix B: +*> +*> N-K-L K L +*> A = K ( 0 A12 A13 ) if M-K-L >= 0; +*> L ( 0 0 A23 ) +*> M-K-L ( 0 0 0 ) +*> +*> N-K-L K L +*> A = K ( 0 A12 A13 ) if M-K-L < 0; +*> M-K ( 0 0 A23 ) +*> +*> N-K-L K L +*> B = L ( 0 0 B13 ) +*> P-L ( 0 0 0 ) +*> +*> where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular +*> upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, +*> otherwise A23 is (M-K)-by-L upper trapezoidal. +*> +*> On exit, +*> +*> U**T *A*Q = D1*( 0 R ), V**T *B*Q = D2*( 0 R ), +*> +*> where U, V and Q are orthogonal matrices. +*> R is a nonsingular upper triangular matrix, and D1 and D2 are +*> ``diagonal'' matrices, which are of the following structures: +*> +*> If M-K-L >= 0, +*> +*> K L +*> D1 = K ( I 0 ) +*> L ( 0 C ) +*> M-K-L ( 0 0 ) +*> +*> K L +*> D2 = L ( 0 S ) +*> P-L ( 0 0 ) +*> +*> N-K-L K L +*> ( 0 R ) = K ( 0 R11 R12 ) K +*> L ( 0 0 R22 ) L +*> +*> where +*> +*> C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), +*> S = diag( BETA(K+1), ... , BETA(K+L) ), +*> C**2 + S**2 = I. +*> +*> R is stored in A(1:K+L,N-K-L+1:N) on exit. +*> +*> If M-K-L < 0, +*> +*> K M-K K+L-M +*> D1 = K ( I 0 0 ) +*> M-K ( 0 C 0 ) +*> +*> K M-K K+L-M +*> D2 = M-K ( 0 S 0 ) +*> K+L-M ( 0 0 I ) +*> P-L ( 0 0 0 ) +*> +*> N-K-L K M-K K+L-M +*> ( 0 R ) = K ( 0 R11 R12 R13 ) +*> M-K ( 0 0 R22 R23 ) +*> K+L-M ( 0 0 0 R33 ) +*> +*> where +*> C = diag( ALPHA(K+1), ... , ALPHA(M) ), +*> S = diag( BETA(K+1), ... , BETA(M) ), +*> C**2 + S**2 = I. +*> +*> R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored +*> ( 0 R22 R23 ) +*> in B(M-K+1:L,N+M-K-L+1:N) on exit. +*> +*> The computation of the orthogonal transformation matrices U, V or Q +*> is optional. These matrices may either be formed explicitly, or they +*> may be postmultiplied into input matrices U1, V1, or Q1. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBU +*> \verbatim +*> JOBU is CHARACTER*1 +*> = 'U': U must contain an orthogonal matrix U1 on entry, and +*> the product U1*U is returned; +*> = 'I': U is initialized to the unit matrix, and the +*> orthogonal matrix U is returned; +*> = 'N': U is not computed. +*> \endverbatim +*> +*> \param[in] JOBV +*> \verbatim +*> JOBV is CHARACTER*1 +*> = 'V': V must contain an orthogonal matrix V1 on entry, and +*> the product V1*V is returned; +*> = 'I': V is initialized to the unit matrix, and the +*> orthogonal matrix V is returned; +*> = 'N': V is not computed. +*> \endverbatim +*> +*> \param[in] JOBQ +*> \verbatim +*> JOBQ is CHARACTER*1 +*> = 'Q': Q must contain an orthogonal matrix Q1 on entry, and +*> the product Q1*Q is returned; +*> = 'I': Q is initialized to the unit matrix, and the +*> orthogonal matrix Q is returned; +*> = 'N': Q is not computed. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows of the matrix B. P >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> +*> K and L specify the subblocks in the input matrices A and B: +*> A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N) +*> of A and B, whose GSVD is going to be computed by DTGSJA. +*> See Further Details. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular +*> matrix R or part of R. See Purpose for details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the P-by-N matrix B. +*> On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains +*> a part of R. See Purpose for details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,P). +*> \endverbatim +*> +*> \param[in] TOLA +*> \verbatim +*> TOLA is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] TOLB +*> \verbatim +*> TOLB is DOUBLE PRECISION +*> +*> TOLA and TOLB are the convergence criteria for the Jacobi- +*> Kogbetliantz iteration procedure. Generally, they are the +*> same as used in the preprocessing step, say +*> TOLA = max(M,N)*norm(A)*MAZHEPS, +*> TOLB = max(P,N)*norm(B)*MAZHEPS. +*> \endverbatim +*> +*> \param[out] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION array, dimension (N) +*> +*> On exit, ALPHA and BETA contain the generalized singular +*> value pairs of A and B; +*> ALPHA(1:K) = 1, +*> BETA(1:K) = 0, +*> and if M-K-L >= 0, +*> ALPHA(K+1:K+L) = diag(C), +*> BETA(K+1:K+L) = diag(S), +*> or if M-K-L < 0, +*> ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 +*> BETA(K+1:M) = S, BETA(M+1:K+L) = 1. +*> Furthermore, if K+L < N, +*> ALPHA(K+L+1:N) = 0 and +*> BETA(K+L+1:N) = 0. +*> \endverbatim +*> +*> \param[in,out] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension (LDU,M) +*> On entry, if JOBU = 'U', U must contain a matrix U1 (usually +*> the orthogonal matrix returned by DGGSVP). +*> On exit, +*> if JOBU = 'I', U contains the orthogonal matrix U; +*> if JOBU = 'U', U contains the product U1*U. +*> If JOBU = 'N', U is not referenced. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of the array U. LDU >= max(1,M) if +*> JOBU = 'U'; LDU >= 1 otherwise. +*> \endverbatim +*> +*> \param[in,out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,P) +*> On entry, if JOBV = 'V', V must contain a matrix V1 (usually +*> the orthogonal matrix returned by DGGSVP). +*> On exit, +*> if JOBV = 'I', V contains the orthogonal matrix V; +*> if JOBV = 'V', V contains the product V1*V. +*> If JOBV = 'N', V is not referenced. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. LDV >= max(1,P) if +*> JOBV = 'V'; LDV >= 1 otherwise. +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ,N) +*> On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually +*> the orthogonal matrix returned by DGGSVP). +*> On exit, +*> if JOBQ = 'I', Q contains the orthogonal matrix Q; +*> if JOBQ = 'Q', Q contains the product Q1*Q. +*> If JOBQ = 'N', Q is not referenced. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= max(1,N) if +*> JOBQ = 'Q'; LDQ >= 1 otherwise. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] NCYCLE +*> \verbatim +*> NCYCLE is INTEGER +*> The number of cycles required for convergence. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> = 1: the procedure does not converge after MAXIT cycles. +*> \endverbatim +*> +*> \verbatim +*> Internal Parameters +*> =================== +*> +*> MAXIT INTEGER +*> MAXIT specifies the total loops that the iterative procedure +*> may take. If after MAXIT cycles, the routine fails to +*> converge, we return INFO = 1. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce +*> min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L +*> matrix B13 to the form: +*> +*> U1**T *A13*Q1 = C1*R1; V1**T *B13*Q1 = S1*R1, +*> +*> where U1, V1 and Q1 are orthogonal matrix, and Z**T is the transpose +*> of Z. C1 and S1 are diagonal matrices satisfying +*> +*> C1**2 + S1**2 = I, +*> +*> and R1 is an L-by-L nonsingular upper triangular matrix. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, + $ LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, + $ Q, LDQ, WORK, NCYCLE, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBQ, JOBU, JOBV + INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, + $ NCYCLE, P + DOUBLE PRECISION TOLA, TOLB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), ALPHA( * ), B( LDB, * ), + $ BETA( * ), Q( LDQ, * ), U( LDU, * ), + $ V( LDV, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 40 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. +* + LOGICAL INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV + INTEGER I, J, KCYCLE + DOUBLE PRECISION A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, ERROR, + $ GAMMA, RWK, SNQ, SNU, SNV, SSMIN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLAGS2, DLAPLL, DLARTG, DLASET, DROT, + $ DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + INITU = LSAME( JOBU, 'I' ) + WANTU = INITU .OR. LSAME( JOBU, 'U' ) +* + INITV = LSAME( JOBV, 'I' ) + WANTV = INITV .OR. LSAME( JOBV, 'V' ) +* + INITQ = LSAME( JOBQ, 'I' ) + WANTQ = INITQ .OR. LSAME( JOBQ, 'Q' ) +* + INFO = 0 + IF( .NOT.( INITU .OR. WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( INITV .OR. WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( INITQ .OR. WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN + INFO = -18 + ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN + INFO = -20 + ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN + INFO = -22 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTGSJA', -INFO ) + RETURN + END IF +* +* Initialize U, V and Q, if necessary +* + IF( INITU ) + $ CALL DLASET( 'Full', M, M, ZERO, ONE, U, LDU ) + IF( INITV ) + $ CALL DLASET( 'Full', P, P, ZERO, ONE, V, LDV ) + IF( INITQ ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) +* +* Loop until convergence +* + UPPER = .FALSE. + DO 40 KCYCLE = 1, MAXIT +* + UPPER = .NOT.UPPER +* + DO 20 I = 1, L - 1 + DO 10 J = I + 1, L +* + A1 = ZERO + A2 = ZERO + A3 = ZERO + IF( K+I.LE.M ) + $ A1 = A( K+I, N-L+I ) + IF( K+J.LE.M ) + $ A3 = A( K+J, N-L+J ) +* + B1 = B( I, N-L+I ) + B3 = B( J, N-L+J ) +* + IF( UPPER ) THEN + IF( K+I.LE.M ) + $ A2 = A( K+I, N-L+J ) + B2 = B( I, N-L+J ) + ELSE + IF( K+J.LE.M ) + $ A2 = A( K+J, N-L+I ) + B2 = B( J, N-L+I ) + END IF +* + CALL DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, + $ CSV, SNV, CSQ, SNQ ) +* +* Update (K+I)-th and (K+J)-th rows of matrix A: U**T *A +* + IF( K+J.LE.M ) + $ CALL DROT( L, A( K+J, N-L+1 ), LDA, A( K+I, N-L+1 ), + $ LDA, CSU, SNU ) +* +* Update I-th and J-th rows of matrix B: V**T *B +* + CALL DROT( L, B( J, N-L+1 ), LDB, B( I, N-L+1 ), LDB, + $ CSV, SNV ) +* +* Update (N-L+I)-th and (N-L+J)-th columns of matrices +* A and B: A*Q and B*Q +* + CALL DROT( MIN( K+L, M ), A( 1, N-L+J ), 1, + $ A( 1, N-L+I ), 1, CSQ, SNQ ) +* + CALL DROT( L, B( 1, N-L+J ), 1, B( 1, N-L+I ), 1, CSQ, + $ SNQ ) +* + IF( UPPER ) THEN + IF( K+I.LE.M ) + $ A( K+I, N-L+J ) = ZERO + B( I, N-L+J ) = ZERO + ELSE + IF( K+J.LE.M ) + $ A( K+J, N-L+I ) = ZERO + B( J, N-L+I ) = ZERO + END IF +* +* Update orthogonal matrices U, V, Q, if desired. +* + IF( WANTU .AND. K+J.LE.M ) + $ CALL DROT( M, U( 1, K+J ), 1, U( 1, K+I ), 1, CSU, + $ SNU ) +* + IF( WANTV ) + $ CALL DROT( P, V( 1, J ), 1, V( 1, I ), 1, CSV, SNV ) +* + IF( WANTQ ) + $ CALL DROT( N, Q( 1, N-L+J ), 1, Q( 1, N-L+I ), 1, CSQ, + $ SNQ ) +* + 10 CONTINUE + 20 CONTINUE +* + IF( .NOT.UPPER ) THEN +* +* The matrices A13 and B13 were lower triangular at the start +* of the cycle, and are now upper triangular. +* +* Convergence test: test the parallelism of the corresponding +* rows of A and B. +* + ERROR = ZERO + DO 30 I = 1, MIN( L, M-K ) + CALL DCOPY( L-I+1, A( K+I, N-L+I ), LDA, WORK, 1 ) + CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, WORK( L+1 ), 1 ) + CALL DLAPLL( L-I+1, WORK, 1, WORK( L+1 ), 1, SSMIN ) + ERROR = MAX( ERROR, SSMIN ) + 30 CONTINUE +* + IF( ABS( ERROR ).LE.MIN( TOLA, TOLB ) ) + $ GO TO 50 + END IF +* +* End of cycle loop +* + 40 CONTINUE +* +* The algorithm has not converged after MAXIT cycles. +* + INFO = 1 + GO TO 100 +* + 50 CONTINUE +* +* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. +* Compute the generalized singular value pairs (ALPHA, BETA), and +* set the triangular matrix R to array A. +* + DO 60 I = 1, K + ALPHA( I ) = ONE + BETA( I ) = ZERO + 60 CONTINUE +* + DO 70 I = 1, MIN( L, M-K ) +* + A1 = A( K+I, N-L+I ) + B1 = B( I, N-L+I ) +* + IF( A1.NE.ZERO ) THEN + GAMMA = B1 / A1 +* +* change sign if necessary +* + IF( GAMMA.LT.ZERO ) THEN + CALL DSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB ) + IF( WANTV ) + $ CALL DSCAL( P, -ONE, V( 1, I ), 1 ) + END IF +* + CALL DLARTG( ABS( GAMMA ), ONE, BETA( K+I ), ALPHA( K+I ), + $ RWK ) +* + IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN + CALL DSCAL( L-I+1, ONE / ALPHA( K+I ), A( K+I, N-L+I ), + $ LDA ) + ELSE + CALL DSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ), + $ LDB ) + CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ), + $ LDA ) + END IF +* + ELSE +* + ALPHA( K+I ) = ZERO + BETA( K+I ) = ONE + CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ), + $ LDA ) +* + END IF +* + 70 CONTINUE +* +* Post-assignment +* + DO 80 I = M + 1, K + L + ALPHA( I ) = ZERO + BETA( I ) = ONE + 80 CONTINUE +* + IF( K+L.LT.N ) THEN + DO 90 I = K + L + 1, N + ALPHA( I ) = ZERO + BETA( I ) = ZERO + 90 CONTINUE + END IF +* + 100 CONTINUE + NCYCLE = KCYCLE + RETURN +* +* End of DTGSJA +* + END diff --git a/math/lapack/src/main/fortran/dtgsna.f b/math/lapack/src/main/fortran/dtgsna.f new file mode 100644 index 0000000000..68a68cad88 --- /dev/null +++ b/math/lapack/src/main/fortran/dtgsna.f @@ -0,0 +1,700 @@ +*> \brief \b DTGSNA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTGSNA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, +* LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, +* IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER HOWMNY, JOB +* INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N +* .. +* .. Array Arguments .. +* LOGICAL SELECT( * ) +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DIF( * ), S( * ), +* $ VL( LDVL, * ), VR( LDVR, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTGSNA estimates reciprocal condition numbers for specified +*> eigenvalues and/or eigenvectors of a matrix pair (A, B) in +*> generalized real Schur canonical form (or of any matrix pair +*> (Q*A*Z**T, Q*B*Z**T) with orthogonal matrices Q and Z, where +*> Z**T denotes the transpose of Z. +*> +*> (A, B) must be in generalized real Schur form (as returned by DGGES), +*> i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal +*> blocks. B is upper triangular. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is CHARACTER*1 +*> Specifies whether condition numbers are required for +*> eigenvalues (S) or eigenvectors (DIF): +*> = 'E': for eigenvalues only (S); +*> = 'V': for eigenvectors only (DIF); +*> = 'B': for both eigenvalues and eigenvectors (S and DIF). +*> \endverbatim +*> +*> \param[in] HOWMNY +*> \verbatim +*> HOWMNY is CHARACTER*1 +*> = 'A': compute condition numbers for all eigenpairs; +*> = 'S': compute condition numbers for selected eigenpairs +*> specified by the array SELECT. +*> \endverbatim +*> +*> \param[in] SELECT +*> \verbatim +*> SELECT is LOGICAL array, dimension (N) +*> If HOWMNY = 'S', SELECT specifies the eigenpairs for which +*> condition numbers are required. To select condition numbers +*> for the eigenpair corresponding to a real eigenvalue w(j), +*> SELECT(j) must be set to .TRUE.. To select condition numbers +*> corresponding to a complex conjugate pair of eigenvalues w(j) +*> and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be +*> set to .TRUE.. +*> If HOWMNY = 'A', SELECT is not referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the square matrix pair (A, B). N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The upper quasi-triangular matrix A in the pair (A,B). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> The upper triangular matrix B in the pair (A,B). +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION array, dimension (LDVL,M) +*> If JOB = 'E' or 'B', VL must contain left eigenvectors of +*> (A, B), corresponding to the eigenpairs specified by HOWMNY +*> and SELECT. The eigenvectors must be stored in consecutive +*> columns of VL, as returned by DTGEVC. +*> If JOB = 'V', VL is not referenced. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the array VL. LDVL >= 1. +*> If JOB = 'E' or 'B', LDVL >= N. +*> \endverbatim +*> +*> \param[in] VR +*> \verbatim +*> VR is DOUBLE PRECISION array, dimension (LDVR,M) +*> If JOB = 'E' or 'B', VR must contain right eigenvectors of +*> (A, B), corresponding to the eigenpairs specified by HOWMNY +*> and SELECT. The eigenvectors must be stored in consecutive +*> columns ov VR, as returned by DTGEVC. +*> If JOB = 'V', VR is not referenced. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. LDVR >= 1. +*> If JOB = 'E' or 'B', LDVR >= N. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (MM) +*> If JOB = 'E' or 'B', the reciprocal condition numbers of the +*> selected eigenvalues, stored in consecutive elements of the +*> array. For a complex conjugate pair of eigenvalues two +*> consecutive elements of S are set to the same value. Thus +*> S(j), DIF(j), and the j-th columns of VL and VR all +*> correspond to the same eigenpair (but not in general the +*> j-th eigenpair, unless all eigenpairs are selected). +*> If JOB = 'V', S is not referenced. +*> \endverbatim +*> +*> \param[out] DIF +*> \verbatim +*> DIF is DOUBLE PRECISION array, dimension (MM) +*> If JOB = 'V' or 'B', the estimated reciprocal condition +*> numbers of the selected eigenvectors, stored in consecutive +*> elements of the array. For a complex eigenvector two +*> consecutive elements of DIF are set to the same value. If +*> the eigenvalues cannot be reordered to compute DIF(j), DIF(j) +*> is set to 0; this can only occur when the true value would be +*> very small anyway. +*> If JOB = 'E', DIF is not referenced. +*> \endverbatim +*> +*> \param[in] MM +*> \verbatim +*> MM is INTEGER +*> The number of elements in the arrays S and DIF. MM >= M. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The number of elements of the arrays S and DIF used to store +*> the specified condition numbers; for each selected real +*> eigenvalue one element is used, and for each selected complex +*> conjugate pair of eigenvalues, two elements are used. +*> If HOWMNY = 'A', M is set to N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= max(1,N). +*> If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N + 6) +*> If JOB = 'E', IWORK is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> =0: Successful exit +*> <0: If INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The reciprocal of the condition number of a generalized eigenvalue +*> w = (a, b) is defined as +*> +*> S(w) = (|u**TAv|**2 + |u**TBv|**2)**(1/2) / (norm(u)*norm(v)) +*> +*> where u and v are the left and right eigenvectors of (A, B) +*> corresponding to w; |z| denotes the absolute value of the complex +*> number, and norm(u) denotes the 2-norm of the vector u. +*> The pair (a, b) corresponds to an eigenvalue w = a/b (= u**TAv/u**TBv) +*> of the matrix pair (A, B). If both a and b equal zero, then (A B) is +*> singular and S(I) = -1 is returned. +*> +*> An approximate error bound on the chordal distance between the i-th +*> computed generalized eigenvalue w and the corresponding exact +*> eigenvalue lambda is +*> +*> chord(w, lambda) <= EPS * norm(A, B) / S(I) +*> +*> where EPS is the machine precision. +*> +*> The reciprocal of the condition number DIF(i) of right eigenvector u +*> and left eigenvector v corresponding to the generalized eigenvalue w +*> is defined as follows: +*> +*> a) If the i-th eigenvalue w = (a,b) is real +*> +*> Suppose U and V are orthogonal transformations such that +*> +*> U**T*(A, B)*V = (S, T) = ( a * ) ( b * ) 1 +*> ( 0 S22 ),( 0 T22 ) n-1 +*> 1 n-1 1 n-1 +*> +*> Then the reciprocal condition number DIF(i) is +*> +*> Difl((a, b), (S22, T22)) = sigma-min( Zl ), +*> +*> where sigma-min(Zl) denotes the smallest singular value of the +*> 2(n-1)-by-2(n-1) matrix +*> +*> Zl = [ kron(a, In-1) -kron(1, S22) ] +*> [ kron(b, In-1) -kron(1, T22) ] . +*> +*> Here In-1 is the identity matrix of size n-1. kron(X, Y) is the +*> Kronecker product between the matrices X and Y. +*> +*> Note that if the default method for computing DIF(i) is wanted +*> (see DLATDF), then the parameter DIFDRI (see below) should be +*> changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). +*> See DTGSYL for more details. +*> +*> b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair, +*> +*> Suppose U and V are orthogonal transformations such that +*> +*> U**T*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2 +*> ( 0 S22 ),( 0 T22) n-2 +*> 2 n-2 2 n-2 +*> +*> and (S11, T11) corresponds to the complex conjugate eigenvalue +*> pair (w, conjg(w)). There exist unitary matrices U1 and V1 such +*> that +*> +*> U1**T*S11*V1 = ( s11 s12 ) and U1**T*T11*V1 = ( t11 t12 ) +*> ( 0 s22 ) ( 0 t22 ) +*> +*> where the generalized eigenvalues w = s11/t11 and +*> conjg(w) = s22/t22. +*> +*> Then the reciprocal condition number DIF(i) is bounded by +*> +*> min( d1, max( 1, |real(s11)/real(s22)| )*d2 ) +*> +*> where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where +*> Z1 is the complex 2-by-2 matrix +*> +*> Z1 = [ s11 -s22 ] +*> [ t11 -t22 ], +*> +*> This is done by computing (using real arithmetic) the +*> roots of the characteristical polynomial det(Z1**T * Z1 - lambda I), +*> where Z1**T denotes the transpose of Z1 and det(X) denotes +*> the determinant of X. +*> +*> and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an +*> upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2) +*> +*> Z2 = [ kron(S11**T, In-2) -kron(I2, S22) ] +*> [ kron(T11**T, In-2) -kron(I2, T22) ] +*> +*> Note that if the default method for computing DIF is wanted (see +*> DLATDF), then the parameter DIFDRI (see below) should be changed +*> from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL +*> for more details. +*> +*> For each eigenvalue/vector specified by SELECT, DIF stores a +*> Frobenius norm-based estimate of Difl. +*> +*> An approximate error bound for the i-th computed eigenvector VL(i) or +*> VR(i) is given by +*> +*> EPS * norm(A, B) / DIF(i). +*> +*> See ref. [2-3] for more details and further references. +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> Bo Kagstrom and Peter Poromaa, Department of Computing Science, +*> Umea University, S-901 87 Umea, Sweden. +* +*> \par References: +* ================ +*> +*> \verbatim +*> +*> [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. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, + $ LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, + $ IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER HOWMNY, JOB + INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DIF( * ), S( * ), + $ VL( LDVL, * ), VR( LDVR, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER DIFDRI + PARAMETER ( DIFDRI = 3 ) + DOUBLE PRECISION ZERO, ONE, TWO, FOUR + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, PAIR, SOMCON, WANTBH, WANTDF, WANTS + INTEGER I, IERR, IFST, ILST, IZ, K, KS, LWMIN, N1, N2 + DOUBLE PRECISION ALPHAI, ALPHAR, ALPRQT, BETA, C1, C2, COND, + $ EPS, LNRM, RNRM, ROOT1, ROOT2, SCALE, SMLNUM, + $ TMPII, TMPIR, TMPRI, TMPRR, UHAV, UHAVI, UHBV, + $ UHBVI +* .. +* .. Local Arrays .. + DOUBLE PRECISION DUMMY( 1 ), DUMMY1( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT, DLAMCH, DLAPY2, DNRM2 + EXTERNAL LSAME, DDOT, DLAMCH, DLAPY2, DNRM2 +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DLACPY, DLAG2, DTGEXC, DTGSYL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + WANTBH = LSAME( JOB, 'B' ) + WANTS = LSAME( JOB, 'E' ) .OR. WANTBH + WANTDF = LSAME( JOB, 'V' ) .OR. WANTBH +* + SOMCON = LSAME( HOWMNY, 'S' ) +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) +* + IF( .NOT.WANTS .AND. .NOT.WANTDF ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( WANTS .AND. LDVL.LT.N ) THEN + INFO = -10 + ELSE IF( WANTS .AND. LDVR.LT.N ) THEN + INFO = -12 + ELSE +* +* Set M to the number of eigenpairs for which condition numbers +* are required, and test MM. +* + IF( SOMCON ) THEN + 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 + ELSE + M = N + END IF +* + IF( N.EQ.0 ) THEN + LWMIN = 1 + ELSE IF( LSAME( JOB, 'V' ) .OR. LSAME( JOB, 'B' ) ) THEN + LWMIN = 2*N*( N + 2 ) + 16 + ELSE + LWMIN = N + END IF + WORK( 1 ) = LWMIN +* + IF( MM.LT.M ) THEN + INFO = -15 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -18 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTGSNA', -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' ) / EPS + KS = 0 + PAIR = .FALSE. +* + DO 20 K = 1, N +* +* Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block. +* + IF( PAIR ) THEN + PAIR = .FALSE. + GO TO 20 + ELSE + IF( K.LT.N ) + $ PAIR = A( K+1, K ).NE.ZERO + END IF +* +* Determine whether condition numbers are required for the k-th +* eigenpair. +* + IF( SOMCON ) THEN + IF( PAIR ) THEN + IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) ) + $ GO TO 20 + ELSE + IF( .NOT.SELECT( K ) ) + $ GO TO 20 + END IF + END IF +* + KS = KS + 1 +* + IF( WANTS ) THEN +* +* Compute the reciprocal condition number of the k-th +* eigenvalue. +* + IF( PAIR ) THEN +* +* Complex eigenvalue pair. +* + RNRM = DLAPY2( DNRM2( N, VR( 1, KS ), 1 ), + $ DNRM2( N, VR( 1, KS+1 ), 1 ) ) + LNRM = DLAPY2( DNRM2( N, VL( 1, KS ), 1 ), + $ DNRM2( N, VL( 1, KS+1 ), 1 ) ) + CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO, + $ WORK, 1 ) + TMPRR = DDOT( N, WORK, 1, VL( 1, KS ), 1 ) + TMPRI = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 ) + CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS+1 ), 1, + $ ZERO, WORK, 1 ) + TMPII = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 ) + TMPIR = DDOT( N, WORK, 1, VL( 1, KS ), 1 ) + UHAV = TMPRR + TMPII + UHAVI = TMPIR - TMPRI + CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO, + $ WORK, 1 ) + TMPRR = DDOT( N, WORK, 1, VL( 1, KS ), 1 ) + TMPRI = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 ) + CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS+1 ), 1, + $ ZERO, WORK, 1 ) + TMPII = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 ) + TMPIR = DDOT( N, WORK, 1, VL( 1, KS ), 1 ) + UHBV = TMPRR + TMPII + UHBVI = TMPIR - TMPRI + UHAV = DLAPY2( UHAV, UHAVI ) + UHBV = DLAPY2( UHBV, UHBVI ) + COND = DLAPY2( UHAV, UHBV ) + S( KS ) = COND / ( RNRM*LNRM ) + S( KS+1 ) = S( KS ) +* + ELSE +* +* Real eigenvalue. +* + RNRM = DNRM2( N, VR( 1, KS ), 1 ) + LNRM = DNRM2( N, VL( 1, KS ), 1 ) + CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO, + $ WORK, 1 ) + UHAV = DDOT( N, WORK, 1, VL( 1, KS ), 1 ) + CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO, + $ WORK, 1 ) + UHBV = DDOT( N, WORK, 1, VL( 1, KS ), 1 ) + COND = DLAPY2( UHAV, UHBV ) + IF( COND.EQ.ZERO ) THEN + S( KS ) = -ONE + ELSE + S( KS ) = COND / ( RNRM*LNRM ) + END IF + END IF + END IF +* + IF( WANTDF ) THEN + IF( N.EQ.1 ) THEN + DIF( KS ) = DLAPY2( A( 1, 1 ), B( 1, 1 ) ) + GO TO 20 + END IF +* +* Estimate the reciprocal condition number of the k-th +* eigenvectors. + IF( PAIR ) THEN +* +* Copy the 2-by 2 pencil beginning at (A(k,k), B(k, k)). +* Compute the eigenvalue(s) at position K. +* + WORK( 1 ) = A( K, K ) + 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, + $ DUMMY1( 1 ), ALPHAR, DUMMY( 1 ), ALPHAI ) + ALPRQT = ONE + C1 = TWO*( ALPHAR*ALPHAR+ALPHAI*ALPHAI+BETA*BETA ) + C2 = FOUR*BETA*BETA*ALPHAI*ALPHAI + ROOT1 = C1 + SQRT( C1*C1-4.0D0*C2 ) + ROOT2 = C2 / ROOT1 + ROOT1 = ROOT1 / TWO + COND = MIN( SQRT( ROOT1 ), SQRT( ROOT2 ) ) + END IF +* +* Copy the matrix (A, B) to the array WORK and swap the +* diagonal block beginning at A(k,k) to the (1,1) position. +* + CALL DLACPY( 'Full', N, N, A, LDA, WORK, N ) + CALL DLACPY( 'Full', N, N, B, LDB, WORK( N*N+1 ), N ) + IFST = K + ILST = 1 +* + CALL DTGEXC( .FALSE., .FALSE., N, WORK, N, WORK( N*N+1 ), N, + $ DUMMY, 1, DUMMY1, 1, IFST, ILST, + $ WORK( N*N*2+1 ), LWORK-2*N*N, IERR ) +* + IF( IERR.GT.0 ) THEN +* +* Ill-conditioned problem - swap rejected. +* + DIF( KS ) = ZERO + ELSE +* +* Reordering successful, solve generalized Sylvester +* equation for R and L, +* A22 * R - L * A11 = A12 +* B22 * R - L * B11 = B12, +* and compute estimate of Difl((A11,B11), (A22, B22)). +* + N1 = 1 + IF( WORK( 2 ).NE.ZERO ) + $ N1 = 2 + N2 = N - N1 + IF( N2.EQ.0 ) THEN + DIF( KS ) = COND + ELSE + I = N*N + 1 + IZ = 2*N*N + 1 + CALL DTGSYL( 'N', DIFDRI, N2, N1, WORK( N*N1+N1+1 ), + $ N, WORK, N, WORK( N1+1 ), N, + $ WORK( N*N1+N1+I ), N, WORK( I ), N, + $ WORK( N1+I ), N, SCALE, DIF( KS ), + $ WORK( IZ+1 ), LWORK-2*N*N, IWORK, IERR ) +* + IF( PAIR ) + $ DIF( KS ) = MIN( MAX( ONE, ALPRQT )*DIF( KS ), + $ COND ) + END IF + END IF + IF( PAIR ) + $ DIF( KS+1 ) = DIF( KS ) + END IF + IF( PAIR ) + $ KS = KS + 1 +* + 20 CONTINUE + WORK( 1 ) = LWMIN + RETURN +* +* End of DTGSNA +* + END diff --git a/math/lapack/src/main/fortran/dtgsy2.f b/math/lapack/src/main/fortran/dtgsy2.f new file mode 100644 index 0000000000..1c687b15e2 --- /dev/null +++ b/math/lapack/src/main/fortran/dtgsy2.f @@ -0,0 +1,1075 @@ +*> \brief \b DTGSY2 solves the generalized Sylvester equation (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTGSY2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, +* LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, +* IWORK, PQ, INFO ) +* +* .. 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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**T, Im) ] (2) +*> [ kron(In, D) -kron(E**T, Im) ], +*> +*> Ik is the identity matrix of size k and X**T 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**T*y = scale*b for y, +*> which is equivalent to solve for R and L in +*> +*> A**T * R + D**T * L = scale * C (3) +*> R * B**T + L * E**T = scale * -F +*> +*> This case is used to compute an estimate of Dif[(A, D), (B, E)] = +*> sigma_min(Z) using reverse communicaton with DLACON. +*> +*> DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL +*> of an upper bound on the separation between to matrix pairs. Then +*> the input (A, D), (B, E) are sub-pencils of the matrix pair in +*> DTGSYL. See DTGSYL for details. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N', solve the generalized Sylvester equation (1). +*> = 'T': solve the 'transposed' system (3). +*> \endverbatim +*> +*> \param[in] IJOB +*> \verbatim +*> IJOB is 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'. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the order of A and D, and the row +*> dimension of C, F, R and L. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of B and E, and the column +*> dimension of C, F, R and L. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, M) +*> On entry, A contains an upper quasi triangular matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the matrix A. LDA >= max(1, M). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB, N) +*> On entry, B contains an upper quasi triangular matrix. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the matrix B. LDB >= max(1, N). +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is 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. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the matrix C. LDC >= max(1, M). +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (LDD, M) +*> On entry, D contains an upper triangular matrix. +*> \endverbatim +*> +*> \param[in] LDD +*> \verbatim +*> LDD is INTEGER +*> The leading dimension of the matrix D. LDD >= max(1, M). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (LDE, N) +*> On entry, E contains an upper triangular matrix. +*> \endverbatim +*> +*> \param[in] LDE +*> \verbatim +*> LDE is INTEGER +*> The leading dimension of the matrix E. LDE >= max(1, N). +*> \endverbatim +*> +*> \param[in,out] F +*> \verbatim +*> F is 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. +*> \endverbatim +*> +*> \param[in] LDF +*> \verbatim +*> LDF is INTEGER +*> The leading dimension of the matrix F. LDF >= max(1, M). +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is 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. +*> \endverbatim +*> +*> \param[in,out] RDSUM +*> \verbatim +*> RDSUM is DOUBLE PRECISION +*> On entry, the sum of squares of computed contributions to +*> the Dif-estimate under computation by DTGSYL, where the +*> scaling factor RDSCAL (see below) has been factored out. +*> On exit, the corresponding sum of squares updated with the +*> contributions from the current sub-system. +*> If TRANS = 'T' RDSUM is not touched. +*> NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL. +*> \endverbatim +*> +*> \param[in,out] RDSCAL +*> \verbatim +*> RDSCAL is 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. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (M+N+2) +*> \endverbatim +*> +*> \param[out] PQ +*> \verbatim +*> PQ is INTEGER +*> On exit, the number of subsystems (of size 2-by-2, 4-by-4 and +*> 8-by-8) solved by this routine. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYauxiliary +* +*> \par Contributors: +* ================== +*> +*> Bo Kagstrom and Peter Poromaa, Department of Computing Science, +*> Umea University, S-901 87 Umea, Sweden. +* +* ===================================================================== + 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.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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, * ) +* .. +* +* ===================================================================== +* 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 = -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.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 ), LDE, F( IS, JE+1 ), LDF ) + 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)**T * R(I, J) + D(I, I)**T * 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 = IWORK ( 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**T * 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**T * 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**T * 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**T * 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**T * 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**T * 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**T * 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**T * 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/math/lapack/src/main/fortran/dtgsyl.f b/math/lapack/src/main/fortran/dtgsyl.f new file mode 100644 index 0000000000..1cc3a1bf89 --- /dev/null +++ b/math/lapack/src/main/fortran/dtgsyl.f @@ -0,0 +1,682 @@ +*> \brief \b DTGSYL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTGSYL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, +* LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, +* IWORK, INFO ) +* +* .. 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( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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**T, Im) ] (2) +*> [ kron(In, D) -kron(E**T, Im) ]. +*> +*> Here Ik is the identity matrix of size k and X**T 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**T*y = scale*b, +*> which is equivalent to solve for R and L in +*> +*> A**T * R + D**T * L = scale * C (3) +*> R * B**T + L * E**T = 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N', solve the generalized Sylvester equation (1). +*> = 'T', solve the 'transposed' system (3). +*> \endverbatim +*> +*> \param[in] IJOB +*> \verbatim +*> IJOB is 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'. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The order of the matrices A and D, and the row dimension of +*> the matrices C, F, R and L. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices B and E, and the column dimension +*> of the matrices C, F, R and L. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, M) +*> The upper quasi triangular matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1, M). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB, N) +*> The upper quasi triangular matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1, N). +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is 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. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1, M). +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (LDD, M) +*> The upper triangular matrix D. +*> \endverbatim +*> +*> \param[in] LDD +*> \verbatim +*> LDD is INTEGER +*> The leading dimension of the array D. LDD >= max(1, M). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (LDE, N) +*> The upper triangular matrix E. +*> \endverbatim +*> +*> \param[in] LDE +*> \verbatim +*> LDE is INTEGER +*> The leading dimension of the array E. LDE >= max(1, N). +*> \endverbatim +*> +*> \param[in,out] F +*> \verbatim +*> F is 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. +*> \endverbatim +*> +*> \param[in] LDF +*> \verbatim +*> LDF is INTEGER +*> The leading dimension of the array F. LDF >= max(1, M). +*> \endverbatim +*> +*> \param[out] DIF +*> \verbatim +*> DIF is 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. +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is 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. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK > = 1. +*> If 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. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (M+N+6) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> Bo Kagstrom and Peter Poromaa, Department of Computing Science, +*> Umea University, S-901 87 Umea, Sweden. +* +*> \par References: +* ================ +*> +*> \verbatim +*> +*> [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. +*> \endverbatim +*> +* ===================================================================== + 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 computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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( * ) +* .. +* +* ===================================================================== +* 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)**T * R(I, J) + D(I, I)**T * L(I, J) = C(I, J) +* R(I, J) * B(J, J)**T + L(I, J) * E(J, J)**T = -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/math/lapack/src/main/fortran/dtpcon.f b/math/lapack/src/main/fortran/dtpcon.f new file mode 100644 index 0000000000..9932a76ab7 --- /dev/null +++ b/math/lapack/src/main/fortran/dtpcon.f @@ -0,0 +1,267 @@ +*> \brief \b DTPCON +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, NORM, UPLO +* INTEGER INFO, N +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION AP( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPCON estimates the reciprocal of the condition number of a packed +*> triangular matrix A, in either the 1-norm or the infinity-norm. +*> +*> The norm of A is computed and an estimate is obtained for +*> norm(inv(A)), then the reciprocal of the condition number is +*> computed as +*> RCOND = 1 / ( norm(A) * norm(inv(A)) ). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is 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. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> = 'N': A is non-unit triangular; +*> = 'U': A is unit triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> The upper or lower triangular matrix A, packed columnwise in +*> a linear array. The j-th column of A is stored in the array +*> AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +*> If DIAG = 'U', the diagonal elements of A are not referenced +*> and are assumed to be 1. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(norm(A) * norm(inv(A))). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, NORM, UPLO + INTEGER INFO, N + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AP( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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, DLANTP + EXTERNAL LSAME, IDAMAX, DLAMCH, DLANTP +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DLATPS, 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 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPCON', -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 = DLANTP( NORM, UPLO, DIAG, N, AP, 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 DLATPS( UPLO, 'No transpose', DIAG, NORMIN, N, AP, + $ WORK, SCALE, WORK( 2*N+1 ), INFO ) + ELSE +* +* Multiply by inv(A**T). +* + CALL DLATPS( UPLO, 'Transpose', DIAG, NORMIN, N, AP, + $ 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 DTPCON +* + END diff --git a/math/lapack/src/main/fortran/dtplqt.f b/math/lapack/src/main/fortran/dtplqt.f new file mode 100644 index 0000000000..b312c501fd --- /dev/null +++ b/math/lapack/src/main/fortran/dtplqt.f @@ -0,0 +1,270 @@ +*> \brief \b DTPLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPLQT computes a blocked LQ factorization of a real +*> "triangular-pentagonal" matrix C, which is composed of a +*> triangular block A and pentagonal block B, using the compact +*> WY representation for Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B, and the order of the +*> triangular matrix A. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the lower trapezoidal part of B. +*> MIN(M,N) >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. M >= MB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the lower triangular N-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the lower triangular matrix L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the pentagonal M-by-N matrix B. The first N-L columns +*> are rectangular, and the last L columns are lower trapezoidal. +*> On exit, B contains the pentagonal matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> The lower triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See Further Details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MB*M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The input matrix C is a M-by-(M+N) matrix +*> +*> C = [ A ] [ B ] +*> +*> +*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal +*> matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L +*> upper trapezoidal matrix B2: +*> [ B ] = [ B1 ] [ B2 ] +*> [ B1 ] <- M-by-(N-L) rectangular +*> [ B2 ] <- M-by-L upper trapezoidal. +*> +*> The lower trapezoidal matrix B2 consists of the first L columns of a +*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is lower triangular. +*> +*> The matrix W stores the elementary reflectors H(i) in the i-th row +*> above the diagonal (of A) in the M-by-(M+N) input matrix C +*> [ C ] = [ A ] [ B ] +*> [ A ] <- lower triangular N-by-N +*> [ B ] <- M-by-N pentagonal +*> +*> so that W can be represented as +*> [ W ] = [ I ] [ V ] +*> [ I ] <- identity, N-by-N +*> [ V ] <- M-by-N, same form as B. +*> +*> Thus, all of information needed for W is contained on exit in B, which +*> we call V above. Note that V has the same form as B; that is, +*> [ V ] = [ V1 ] [ V2 ] +*> [ V1 ] <- M-by-(N-L) rectangular +*> [ V2 ] <- M-by-L lower trapezoidal. +*> +*> The rows of V represent the vectors which define the H(i)'s. +*> +*> The number of blocks is B = ceiling(M/MB), where each +*> block is of order MB except for the last block, which is of order +*> IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block +*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB +*> for the last block) T's are stored in the MB-by-N matrix T as +*> +*> T = [T1 T2 ... TB]. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I, IB, LB, NB, IINFO +* .. +* .. External Subroutines .. + EXTERNAL DTPLQT2, DTPRFB, XERBLA +* .. +* .. 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( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN + INFO = -3 + ELSE IF( MB.LT.1 .OR. (MB.GT.M .AND. M.GT.0)) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MB ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPLQT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) RETURN +* + DO I = 1, M, MB +* +* Compute the QR factorization of the current block +* + IB = MIN( M-I+1, MB ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF +* + CALL DTPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB, + $ T(1, I ), LDT, IINFO ) +* +* Update by applying H**T to B(I+IB:M,:) from the right +* + IF( I+IB.LE.M ) THEN + CALL DTPRFB( 'R', 'N', 'F', 'R', M-I-IB+1, NB, IB, LB, + $ B( I, 1 ), LDB, T( 1, I ), LDT, + $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB, + $ WORK, M-I-IB+1) + END IF + END DO + RETURN +* +* End of DTPLQT +* + END diff --git a/math/lapack/src/main/fortran/dtplqt2.f b/math/lapack/src/main/fortran/dtplqt2.f new file mode 100644 index 0000000000..7e87e6c5b6 --- /dev/null +++ b/math/lapack/src/main/fortran/dtplqt2.f @@ -0,0 +1,312 @@ +*> \brief \b DTPLQT2 computes a LQ factorization of a real or complex "triangular-pentagonal" matrix, which is composed of a triangular block and a pentagonal block, using the compact WY representation for Q. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPLQT2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDT, N, M, L +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPLQT2 computes a LQ a factorization of a real "triangular-pentagonal" +*> matrix C, which is composed of a triangular block A and pentagonal block B, +*> using the compact WY representation for Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The total number of rows of the matrix B. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B, and the order of +*> the triangular matrix A. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the lower trapezoidal part of B. +*> MIN(M,N) >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the lower triangular M-by-M matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the lower triangular matrix L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the pentagonal M-by-N matrix B. The first N-L columns +*> are rectangular, and the last L columns are lower trapezoidal. +*> On exit, B contains the pentagonal matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,M) +*> The N-by-N upper triangular factor T of the block reflector. +*> See Further Details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The input matrix C is a M-by-(M+N) matrix +*> +*> C = [ A ][ B ] +*> +*> +*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal +*> matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L +*> upper trapezoidal matrix B2: +*> +*> B = [ B1 ][ B2 ] +*> [ B1 ] <- M-by-(N-L) rectangular +*> [ B2 ] <- M-by-L lower trapezoidal. +*> +*> The lower trapezoidal matrix B2 consists of the first L columns of a +*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is lower triangular. +*> +*> The matrix W stores the elementary reflectors H(i) in the i-th row +*> above the diagonal (of A) in the M-by-(M+N) input matrix C +*> +*> C = [ A ][ B ] +*> [ A ] <- lower triangular N-by-N +*> [ B ] <- M-by-N pentagonal +*> +*> so that W can be represented as +*> +*> W = [ I ][ V ] +*> [ I ] <- identity, N-by-N +*> [ V ] <- M-by-N, same form as B. +*> +*> Thus, all of information needed for W is contained on exit in B, which +*> we call V above. Note that V has the same form as B; that is, +*> +*> W = [ V1 ][ V2 ] +*> [ V1 ] <- M-by-(N-L) rectangular +*> [ V2 ] <- M-by-L lower trapezoidal. +*> +*> The rows of V represent the vectors which define the H(i)'s. +*> The (M+N)-by-(M+N) block reflector H is then given by +*> +*> H = I - W**T * T * W +*> +*> where W^H is the conjugate transpose of W and T is the upper triangular +*> factor of the block reflector. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDT, N, M, L +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER( ONE = 1.0, ZERO = 0.0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, P, MP, NP + DOUBLE PRECISION ALPHA +* .. +* .. External Subroutines .. + EXTERNAL DLARFG, DGEMV, DGER, DTRMV, 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( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSE IF( LDT.LT.MAX( 1, M ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPLQT2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. M.EQ.0 ) RETURN +* + DO I = 1, M +* +* Generate elementary reflector H(I) to annihilate B(I,:) +* + P = N-L+MIN( L, I ) + CALL DLARFG( P+1, A( I, I ), B( I, 1 ), LDB, T( 1, I ) ) + IF( I.LT.M ) THEN +* +* W(M-I:1) := C(I+1:M,I:N) * C(I,I:N) [use W = T(M,:)] +* + DO J = 1, M-I + T( M, J ) = (A( I+J, I )) + END DO + CALL DGEMV( 'N', M-I, P, ONE, B( I+1, 1 ), LDB, + $ B( I, 1 ), LDB, ONE, T( M, 1 ), LDT ) +* +* C(I+1:M,I:N) = C(I+1:M,I:N) + alpha * C(I,I:N)*W(M-1:1)^H +* + ALPHA = -(T( 1, I )) + DO J = 1, M-I + A( I+J, I ) = A( I+J, I ) + ALPHA*(T( M, J )) + END DO + CALL DGER( M-I, P, ALPHA, T( M, 1 ), LDT, + $ B( I, 1 ), LDB, B( I+1, 1 ), LDB ) + END IF + END DO +* + DO I = 2, M +* +* T(I,1:I-1) := C(I:I-1,1:N) * (alpha * C(I,I:N)^H) +* + ALPHA = -T( 1, I ) + + DO J = 1, I-1 + T( I, J ) = ZERO + END DO + P = MIN( I-1, L ) + NP = MIN( N-L+1, N ) + MP = MIN( P+1, M ) +* +* Triangular part of B2 +* + DO J = 1, P + T( I, J ) = ALPHA*B( I, N-L+J ) + END DO + CALL DTRMV( 'L', 'N', 'N', P, B( 1, NP ), LDB, + $ T( I, 1 ), LDT ) +* +* Rectangular part of B2 +* + CALL DGEMV( 'N', I-1-P, L, ALPHA, B( MP, NP ), LDB, + $ B( I, NP ), LDB, ZERO, T( I,MP ), LDT ) +* +* B1 +* + CALL DGEMV( 'N', I-1, N-L, ALPHA, B, LDB, B( I, 1 ), LDB, + $ ONE, T( I, 1 ), LDT ) +* +* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1) +* + CALL DTRMV( 'L', 'T', 'N', I-1, T, LDT, T( I, 1 ), LDT ) +* +* T(I,I) = tau(I) +* + T( I, I ) = T( 1, I ) + T( 1, I ) = ZERO + END DO + DO I=1,M + DO J= I+1,M + T(I,J)=T(J,I) + T(J,I)= ZERO + END DO + END DO + +* +* End of DTPLQT2 +* + END diff --git a/math/lapack/src/main/fortran/dtpmlqt.f b/math/lapack/src/main/fortran/dtpmlqt.f new file mode 100644 index 0000000000..fd31bed57a --- /dev/null +++ b/math/lapack/src/main/fortran/dtpmlqt.f @@ -0,0 +1,366 @@ +*> \brief \b DTPMLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, +* A, LDA, B, LDB, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT +* .. +* .. Array Arguments .. +* DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), +* $ T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPMQRT applies a real orthogonal matrix Q obtained from a +*> "triangular-pentagonal" real block reflector H to a general +*> real matrix C, which consists of two blocks A and B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The order of the trapezoidal part of V. +*> K >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size used for the storage of T. K >= MB >= 1. +*> This must be the same value of MB used to generate T +*> in DTPLQT. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDA,K) +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DTPLQT in B. See Further Details. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If SIDE = 'L', LDV >= max(1,M); +*> if SIDE = 'R', LDV >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,K) +*> The upper triangular factors of the block reflectors +*> as returned by DTPLQT, stored as a MB-by-K matrix. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension +*> (LDA,N) if SIDE = 'L' or +*> (LDA,K) if SIDE = 'R' +*> On entry, the K-by-N or M-by-K matrix A. +*> On exit, A is overwritten by the corresponding block of +*> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDC >= max(1,K); +*> If SIDE = 'R', LDC >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the M-by-N matrix B. +*> On exit, B is overwritten by the corresponding block of +*> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. +*> LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array. The dimension of WORK is +*> N*MB if SIDE = 'L', or M*MB if SIDE = 'R'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The columns of the pentagonal matrix V contain the elementary reflectors +*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a +*> trapezoidal block V2: +*> +*> V = [V1] [V2]. +*> +*> +*> The size of the trapezoidal block V2 is determined by the parameter L, +*> where 0 <= L <= K; V2 is lower trapezoidal, consisting of the first L +*> rows of a K-by-K upper triangular matrix. If L=K, V2 is lower triangular; +*> if L=0, there is no trapezoidal block, hence V = V1 is rectangular. +*> +*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is K-by-M. +*> [B] +*> +*> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is K-by-N. +*> +*> The real orthogonal matrix Q is formed from V and T. +*> +*> If TRANS='N' and SIDE='L', C is on exit replaced with Q * C. +*> +*> If TRANS='T' and SIDE='L', C is on exit replaced with Q**T * C. +*> +*> If TRANS='N' and SIDE='R', C is on exit replaced with C * Q. +*> +*> If TRANS='T' and SIDE='R', C is on exit replaced with C * Q**T. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, + $ A, LDA, B, LDB, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT +* .. +* .. Array Arguments .. + DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), + $ T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN + INTEGER I, IB, NB, LB, KF, LDAQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLARFB +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* .. Test the input arguments .. +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + TRAN = LSAME( TRANS, 'T' ) + NOTRAN = LSAME( TRANS, 'N' ) +* + IF ( LEFT ) THEN + LDAQ = MAX( 1, K ) + ELSE IF ( RIGHT ) THEN + LDAQ = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( L.LT.0 .OR. L.GT.K ) THEN + INFO = -6 + ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0) ) THEN + INFO = -7 + ELSE IF( LDV.LT.K ) THEN + INFO = -9 + ELSE IF( LDT.LT.MB ) THEN + INFO = -11 + ELSE IF( LDA.LT.LDAQ ) THEN + INFO = -13 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -15 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPMLQT', -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 ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + NB = MIN( M-L+I+IB-1, M ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = 0 + END IF + CALL DTPRFB( 'L', 'T', 'F', 'R', NB, N, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( I, 1 ), LDA, B, LDB, WORK, IB ) + END DO +* + ELSE IF( RIGHT .AND. TRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF + CALL DTPRFB( 'R', 'N', 'F', 'R', M, NB, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( 1, I ), LDA, B, LDB, WORK, M ) + END DO +* + ELSE IF( LEFT .AND. TRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + NB = MIN( M-L+I+IB-1, M ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = 0 + END IF + CALL DTPRFB( 'L', 'N', 'F', 'R', NB, N, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( I, 1 ), LDA, B, LDB, WORK, IB ) + END DO +* + ELSE IF( RIGHT .AND. NOTRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF + CALL DTPRFB( 'R', 'T', 'F', 'R', M, NB, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( 1, I ), LDA, B, LDB, WORK, M ) + END DO +* + END IF +* + RETURN +* +* End of DTPMLQT +* + END diff --git a/math/lapack/src/main/fortran/dtpmqrt.f b/math/lapack/src/main/fortran/dtpmqrt.f new file mode 100644 index 0000000000..ba9fdf858e --- /dev/null +++ b/math/lapack/src/main/fortran/dtpmqrt.f @@ -0,0 +1,368 @@ +*> \brief \b DTPMQRT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, +* A, LDA, B, LDB, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT +* .. +* .. Array Arguments .. +* DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), +* $ T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPMQRT applies a real orthogonal matrix Q obtained from a +*> "triangular-pentagonal" real block reflector H to a general +*> real matrix C, which consists of two blocks A and B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The order of the trapezoidal part of V. +*> K >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The block size used for the storage of T. K >= NB >= 1. +*> This must be the same value of NB used to generate T +*> in CTPQRT. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> CTPQRT in B. See Further Details. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If SIDE = 'L', LDV >= max(1,M); +*> if SIDE = 'R', LDV >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,K) +*> The upper triangular factors of the block reflectors +*> as returned by CTPQRT, stored as a NB-by-K matrix. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension +*> (LDA,N) if SIDE = 'L' or +*> (LDA,K) if SIDE = 'R' +*> On entry, the K-by-N or M-by-K matrix A. +*> On exit, A is overwritten by the corresponding block of +*> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDC >= max(1,K); +*> If SIDE = 'R', LDC >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the M-by-N matrix B. +*> On exit, B is overwritten by the corresponding block of +*> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. +*> LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array. The dimension of WORK is +*> N*NB if SIDE = 'L', or M*NB if SIDE = 'R'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The columns of the pentagonal matrix V contain the elementary reflectors +*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a +*> trapezoidal block V2: +*> +*> V = [V1] +*> [V2]. +*> +*> The size of the trapezoidal block V2 is determined by the parameter L, +*> where 0 <= L <= K; V2 is upper trapezoidal, consisting of the first L +*> rows of a K-by-K upper triangular matrix. If L=K, V2 is upper triangular; +*> if L=0, there is no trapezoidal block, hence V = V1 is rectangular. +*> +*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is M-by-K. +*> [B] +*> +*> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is N-by-K. +*> +*> The real orthogonal matrix Q is formed from V and T. +*> +*> If TRANS='N' and SIDE='L', C is on exit replaced with Q * C. +*> +*> If TRANS='T' and SIDE='L', C is on exit replaced with Q**T * C. +*> +*> If TRANS='N' and SIDE='R', C is on exit replaced with C * Q. +*> +*> If TRANS='T' and SIDE='R', C is on exit replaced with C * Q**T. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, + $ A, LDA, B, LDB, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT +* .. +* .. Array Arguments .. + DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), + $ T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN + INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* .. Test the input arguments .. +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + TRAN = LSAME( TRANS, 'T' ) + NOTRAN = LSAME( TRANS, 'N' ) +* + IF ( LEFT ) THEN + LDVQ = MAX( 1, M ) + LDAQ = MAX( 1, K ) + ELSE IF ( RIGHT ) THEN + LDVQ = MAX( 1, N ) + LDAQ = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( L.LT.0 .OR. L.GT.K ) THEN + INFO = -6 + ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN + INFO = -7 + ELSE IF( LDV.LT.LDVQ ) THEN + INFO = -9 + ELSE IF( LDT.LT.NB ) THEN + INFO = -11 + ELSE IF( LDA.LT.LDAQ ) THEN + INFO = -13 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -15 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPMQRT', -INFO ) + RETURN + END IF +* +* .. Quick return if possible .. +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN +* + IF( LEFT .AND. TRAN ) THEN +* + DO I = 1, K, NB + IB = MIN( NB, K-I+1 ) + MB = MIN( M-L+I+IB-1, M ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = MB-M+L-I+1 + END IF + CALL DTPRFB( 'L', 'T', 'F', 'C', MB, N, IB, LB, + $ V( 1, I ), LDV, T( 1, I ), LDT, + $ A( I, 1 ), LDA, B, LDB, WORK, IB ) + END DO +* + ELSE IF( RIGHT .AND. NOTRAN ) THEN +* + DO I = 1, K, NB + IB = MIN( NB, K-I+1 ) + MB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = MB-N+L-I+1 + END IF + CALL DTPRFB( 'R', 'N', 'F', 'C', M, MB, IB, LB, + $ V( 1, I ), LDV, T( 1, I ), LDT, + $ A( 1, I ), LDA, B, LDB, WORK, M ) + END DO +* + ELSE IF( LEFT .AND. NOTRAN ) THEN +* + KF = ((K-1)/NB)*NB+1 + DO I = KF, 1, -NB + IB = MIN( NB, K-I+1 ) + MB = MIN( M-L+I+IB-1, M ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = MB-M+L-I+1 + END IF + CALL DTPRFB( 'L', 'N', 'F', 'C', MB, N, IB, LB, + $ V( 1, I ), LDV, T( 1, I ), LDT, + $ A( I, 1 ), LDA, B, LDB, WORK, IB ) + END DO +* + ELSE IF( RIGHT .AND. TRAN ) THEN +* + KF = ((K-1)/NB)*NB+1 + DO I = KF, 1, -NB + IB = MIN( NB, K-I+1 ) + MB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = MB-N+L-I+1 + END IF + CALL DTPRFB( 'R', 'T', 'F', 'C', M, MB, IB, LB, + $ V( 1, I ), LDV, T( 1, I ), LDT, + $ A( 1, I ), LDA, B, LDB, WORK, M ) + END DO +* + END IF +* + RETURN +* +* End of DTPMQRT +* + END diff --git a/math/lapack/src/main/fortran/dtpqrt.f b/math/lapack/src/main/fortran/dtpqrt.f new file mode 100644 index 0000000000..1a3f95475b --- /dev/null +++ b/math/lapack/src/main/fortran/dtpqrt.f @@ -0,0 +1,270 @@ +*> \brief \b DTPQRT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDT, N, M, L, NB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPQRT computes a blocked QR factorization of a real +*> "triangular-pentagonal" matrix C, which is composed of a +*> triangular block A and pentagonal block B, using the compact +*> WY representation for Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B, and the order of the +*> triangular matrix A. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the upper trapezoidal part of B. +*> MIN(M,N) >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The block size to be used in the blocked QR. N >= NB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the upper triangular N-by-N matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the upper triangular matrix R. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the pentagonal M-by-N matrix B. The first M-L rows +*> are rectangular, and the last L rows are upper trapezoidal. +*> On exit, B contains the pentagonal matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> The upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See Further Details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (NB*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The input matrix C is a (N+M)-by-N matrix +*> +*> C = [ A ] +*> [ B ] +*> +*> where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal +*> matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N +*> upper trapezoidal matrix B2: +*> +*> B = [ B1 ] <- (M-L)-by-N rectangular +*> [ B2 ] <- L-by-N upper trapezoidal. +*> +*> The upper trapezoidal matrix B2 consists of the first L rows of a +*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is upper triangular. +*> +*> The matrix W stores the elementary reflectors H(i) in the i-th column +*> below the diagonal (of A) in the (N+M)-by-N input matrix C +*> +*> C = [ A ] <- upper triangular N-by-N +*> [ B ] <- M-by-N pentagonal +*> +*> so that W can be represented as +*> +*> W = [ I ] <- identity, N-by-N +*> [ V ] <- M-by-N, same form as B. +*> +*> Thus, all of information needed for W is contained on exit in B, which +*> we call V above. Note that V has the same form as B; that is, +*> +*> V = [ V1 ] <- (M-L)-by-N rectangular +*> [ V2 ] <- L-by-N upper trapezoidal. +*> +*> The columns of V represent the vectors which define the H(i)'s. +*> +*> The number of blocks is B = ceiling(N/NB), where each +*> block is of order NB except for the last block, which is of order +*> IB = N - (B-1)*NB. For each of the B blocks, a upper triangular block +*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB +*> for the last block) T's are stored in the NB-by-N matrix T as +*> +*> T = [T1 T2 ... TB]. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDT, N, M, L, NB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I, IB, LB, MB, IINFO +* .. +* .. External Subroutines .. + EXTERNAL DTPQRT2, DTPRFB, XERBLA +* .. +* .. 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( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN + INFO = -3 + ELSE IF( NB.LT.1 .OR. (NB.GT.N .AND. N.GT.0)) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.NB ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPQRT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) RETURN +* + DO I = 1, N, NB +* +* Compute the QR factorization of the current block +* + IB = MIN( N-I+1, NB ) + MB = MIN( M-L+I+IB-1, M ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = MB-M+L-I+1 + END IF +* + CALL DTPQRT2( MB, IB, LB, A(I,I), LDA, B( 1, I ), LDB, + $ T(1, I ), LDT, IINFO ) +* +* Update by applying H**T to B(:,I+IB:N) from the left +* + IF( I+IB.LE.N ) THEN + CALL DTPRFB( 'L', 'T', 'F', 'C', MB, N-I-IB+1, IB, LB, + $ B( 1, I ), LDB, T( 1, I ), LDT, + $ A( I, I+IB ), LDA, B( 1, I+IB ), LDB, + $ WORK, IB ) + END IF + END DO + RETURN +* +* End of DTPQRT +* + END diff --git a/math/lapack/src/main/fortran/dtpqrt2.f b/math/lapack/src/main/fortran/dtpqrt2.f new file mode 100644 index 0000000000..2e18f4e3a0 --- /dev/null +++ b/math/lapack/src/main/fortran/dtpqrt2.f @@ -0,0 +1,302 @@ +*> \brief \b DTPQRT2 computes a QR factorization of a real or complex "triangular-pentagonal" matrix, which is composed of a triangular block and a pentagonal block, using the compact WY representation for Q. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPQRT2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDT, N, M, L +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPQRT2 computes a QR factorization of a real "triangular-pentagonal" +*> matrix C, which is composed of a triangular block A and pentagonal block B, +*> using the compact WY representation for Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The total number of rows of the matrix B. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B, and the order of +*> the triangular matrix A. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the upper trapezoidal part of B. +*> MIN(M,N) >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the upper triangular N-by-N matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the upper triangular matrix R. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the pentagonal M-by-N matrix B. The first M-L rows +*> are rectangular, and the last L rows are upper trapezoidal. +*> On exit, B contains the pentagonal matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> The N-by-N upper triangular factor T of the block reflector. +*> See Further Details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The input matrix C is a (N+M)-by-N matrix +*> +*> C = [ A ] +*> [ B ] +*> +*> where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal +*> matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N +*> upper trapezoidal matrix B2: +*> +*> B = [ B1 ] <- (M-L)-by-N rectangular +*> [ B2 ] <- L-by-N upper trapezoidal. +*> +*> The upper trapezoidal matrix B2 consists of the first L rows of a +*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is upper triangular. +*> +*> The matrix W stores the elementary reflectors H(i) in the i-th column +*> below the diagonal (of A) in the (N+M)-by-N input matrix C +*> +*> C = [ A ] <- upper triangular N-by-N +*> [ B ] <- M-by-N pentagonal +*> +*> so that W can be represented as +*> +*> W = [ I ] <- identity, N-by-N +*> [ V ] <- M-by-N, same form as B. +*> +*> Thus, all of information needed for W is contained on exit in B, which +*> we call V above. Note that V has the same form as B; that is, +*> +*> V = [ V1 ] <- (M-L)-by-N rectangular +*> [ V2 ] <- L-by-N upper trapezoidal. +*> +*> The columns of V represent the vectors which define the H(i)'s. +*> The (M+N)-by-(M+N) block reflector H is then given by +*> +*> H = I - W * T * W**T +*> +*> where W^H is the conjugate transpose of W and T is the upper triangular +*> factor of the block reflector. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDT, N, M, L +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER( ONE = 1.0, ZERO = 0.0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, P, MP, NP + DOUBLE PRECISION ALPHA +* .. +* .. External Subroutines .. + EXTERNAL DLARFG, DGEMV, DGER, DTRMV, 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( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPQRT2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. M.EQ.0 ) RETURN +* + DO I = 1, N +* +* Generate elementary reflector H(I) to annihilate B(:,I) +* + P = M-L+MIN( L, I ) + CALL DLARFG( P+1, A( I, I ), B( 1, I ), 1, T( I, 1 ) ) + IF( I.LT.N ) THEN +* +* W(1:N-I) := C(I:M,I+1:N)^H * C(I:M,I) [use W = T(:,N)] +* + DO J = 1, N-I + T( J, N ) = (A( I, I+J )) + END DO + CALL DGEMV( 'T', P, N-I, ONE, B( 1, I+1 ), LDB, + $ B( 1, I ), 1, ONE, T( 1, N ), 1 ) +* +* C(I:M,I+1:N) = C(I:m,I+1:N) + alpha*C(I:M,I)*W(1:N-1)^H +* + ALPHA = -(T( I, 1 )) + DO J = 1, N-I + A( I, I+J ) = A( I, I+J ) + ALPHA*(T( J, N )) + END DO + CALL DGER( P, N-I, ALPHA, B( 1, I ), 1, + $ T( 1, N ), 1, B( 1, I+1 ), LDB ) + END IF + END DO +* + DO I = 2, N +* +* T(1:I-1,I) := C(I:M,1:I-1)^H * (alpha * C(I:M,I)) +* + ALPHA = -T( I, 1 ) + + DO J = 1, I-1 + T( J, I ) = ZERO + END DO + P = MIN( I-1, L ) + MP = MIN( M-L+1, M ) + NP = MIN( P+1, N ) +* +* Triangular part of B2 +* + DO J = 1, P + T( J, I ) = ALPHA*B( M-L+J, I ) + END DO + CALL DTRMV( 'U', 'T', 'N', P, B( MP, 1 ), LDB, + $ T( 1, I ), 1 ) +* +* Rectangular part of B2 +* + CALL DGEMV( 'T', L, I-1-P, ALPHA, B( MP, NP ), LDB, + $ B( MP, I ), 1, ZERO, T( NP, I ), 1 ) +* +* B1 +* + CALL DGEMV( 'T', M-L, I-1, ALPHA, B, LDB, B( 1, I ), 1, + $ ONE, T( 1, I ), 1 ) +* +* T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) +* + CALL DTRMV( 'U', 'N', 'N', I-1, T, LDT, T( 1, I ), 1 ) +* +* T(I,I) = tau(I) +* + T( I, I ) = T( I, 1 ) + T( I, 1 ) = ZERO + END DO + +* +* End of DTPQRT2 +* + END diff --git a/math/lapack/src/main/fortran/dtprfb.f b/math/lapack/src/main/fortran/dtprfb.f new file mode 100644 index 0000000000..6ae8fad8c4 --- /dev/null +++ b/math/lapack/src/main/fortran/dtprfb.f @@ -0,0 +1,811 @@ +*> \brief \b DTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matrix, which is composed of two blocks. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPRFB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, +* V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK ) +* +* .. Scalar Arguments .. +* CHARACTER DIRECT, SIDE, STOREV, TRANS +* INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), +* $ V( LDV, * ), WORK( LDWORK, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPRFB applies a real "triangular-pentagonal" block reflector H or its +*> transpose H**T to a real matrix C, which is composed of two +*> blocks A and B, either from the left or right. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply H or H**T from the Left +*> = 'R': apply H or H**T from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply H (No transpose) +*> = 'T': apply H**T (Transpose) +*> \endverbatim +*> +*> \param[in] DIRECT +*> \verbatim +*> DIRECT is 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) +*> \endverbatim +*> +*> \param[in] STOREV +*> \verbatim +*> STOREV is CHARACTER*1 +*> Indicates how the vectors which define the elementary +*> reflectors are stored: +*> = 'C': Columns +*> = 'R': Rows +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The order of the matrix T, i.e. the number of elementary +*> reflectors whose product defines the block reflector. +*> K >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The order of the trapezoidal part of V. +*> K >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is 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 pentagonal matrix V, which contains the elementary reflectors +*> H(1), H(2), ..., H(K). See Further Details. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is 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. +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,K) +*> The triangular K-by-K matrix T in the representation of the +*> block reflector. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. +*> LDT >= K. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension +*> (LDA,N) if SIDE = 'L' or (LDA,K) if SIDE = 'R' +*> On entry, the K-by-N or M-by-K matrix A. +*> On exit, A is overwritten by the corresponding block of +*> H*C or H**T*C or C*H or C*H**T. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDC >= max(1,K); +*> If SIDE = 'R', LDC >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the M-by-N matrix B. +*> On exit, B is overwritten by the corresponding block of +*> H*C or H**T*C or C*H or C*H**T. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. +*> LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (LDWORK,N) if SIDE = 'L', +*> (LDWORK,K) if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDWORK +*> \verbatim +*> LDWORK is INTEGER +*> The leading dimension of the array WORK. +*> If SIDE = 'L', LDWORK >= K; +*> if SIDE = 'R', LDWORK >= M. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix C is a composite matrix formed from blocks A and B. +*> The block B is of size M-by-N; if SIDE = 'R', A is of size M-by-K, +*> and if SIDE = 'L', A is of size K-by-N. +*> +*> If SIDE = 'R' and DIRECT = 'F', C = [A B]. +*> +*> If SIDE = 'L' and DIRECT = 'F', C = [A] +*> [B]. +*> +*> If SIDE = 'R' and DIRECT = 'B', C = [B A]. +*> +*> If SIDE = 'L' and DIRECT = 'B', C = [B] +*> [A]. +*> +*> The pentagonal matrix V is composed of a rectangular block V1 and a +*> trapezoidal block V2. The size of the trapezoidal block is determined by +*> the parameter L, where 0<=L<=K. If L=K, the V2 block of V is triangular; +*> if L=0, there is no trapezoidal block, thus V = V1 is rectangular. +*> +*> If DIRECT = 'F' and STOREV = 'C': V = [V1] +*> [V2] +*> - V2 is upper trapezoidal (first L rows of K-by-K upper triangular) +*> +*> If DIRECT = 'F' and STOREV = 'R': V = [V1 V2] +*> +*> - V2 is lower trapezoidal (first L columns of K-by-K lower triangular) +*> +*> If DIRECT = 'B' and STOREV = 'C': V = [V2] +*> [V1] +*> - V2 is lower trapezoidal (last L rows of K-by-K lower triangular) +*> +*> If DIRECT = 'B' and STOREV = 'R': V = [V2 V1] +*> +*> - V2 is upper trapezoidal (last L columns of K-by-K upper triangular) +*> +*> If STOREV = 'C' and SIDE = 'L', V is M-by-K with V2 L-by-K. +*> +*> If STOREV = 'C' and SIDE = 'R', V is N-by-K with V2 L-by-K. +*> +*> If STOREV = 'R' and SIDE = 'L', V is K-by-M with V2 K-by-L. +*> +*> If STOREV = 'R' and SIDE = 'R', V is K-by-N with V2 K-by-L. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, + $ V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), + $ V( LDV, * ), WORK( LDWORK, * ) +* .. +* +* ========================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0, ZERO = 0.0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, MP, NP, KP + LOGICAL LEFT, FORWARD, COLUMN, RIGHT, BACKWARD, ROW +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DTRMM +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 .OR. K.LE.0 .OR. L.LT.0 ) RETURN +* + IF( LSAME( STOREV, 'C' ) ) THEN + COLUMN = .TRUE. + ROW = .FALSE. + ELSE IF ( LSAME( STOREV, 'R' ) ) THEN + COLUMN = .FALSE. + ROW = .TRUE. + ELSE + COLUMN = .FALSE. + ROW = .FALSE. + END IF +* + IF( LSAME( SIDE, 'L' ) ) THEN + LEFT = .TRUE. + RIGHT = .FALSE. + ELSE IF( LSAME( SIDE, 'R' ) ) THEN + LEFT = .FALSE. + RIGHT = .TRUE. + ELSE + LEFT = .FALSE. + RIGHT = .FALSE. + END IF +* + IF( LSAME( DIRECT, 'F' ) ) THEN + FORWARD = .TRUE. + BACKWARD = .FALSE. + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + FORWARD = .FALSE. + BACKWARD = .TRUE. + ELSE + FORWARD = .FALSE. + BACKWARD = .FALSE. + END IF +* +* --------------------------------------------------------------------------- +* + IF( COLUMN .AND. FORWARD .AND. LEFT ) THEN +* +* --------------------------------------------------------------------------- +* +* Let W = [ I ] (K-by-K) +* [ V ] (M-by-K) +* +* Form H C or H**T C where C = [ A ] (K-by-N) +* [ B ] (M-by-N) +* +* H = I - W T W**T or H**T = I - W T**T W**T +* +* A = A - T (A + V**T B) or A = A - T**T (A + V**T B) +* B = B - V T (A + V**T B) or B = B - V T**T (A + V**T B) +* +* --------------------------------------------------------------------------- +* + MP = MIN( M-L+1, M ) + KP = MIN( L+1, K ) +* + DO J = 1, N + DO I = 1, L + WORK( I, J ) = B( M-L+I, J ) + END DO + END DO + CALL DTRMM( 'L', 'U', 'T', 'N', L, N, ONE, V( MP, 1 ), LDV, + $ WORK, LDWORK ) + CALL DGEMM( 'T', 'N', L, N, M-L, ONE, V, LDV, B, LDB, + $ ONE, WORK, LDWORK ) + CALL DGEMM( 'T', 'N', K-L, N, M, ONE, V( 1, KP ), LDV, + $ B, LDB, ZERO, WORK( KP, 1 ), LDWORK ) +* + DO J = 1, N + DO I = 1, K + WORK( I, J ) = WORK( I, J ) + A( I, J ) + END DO + END DO +* + CALL DTRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, + $ WORK, LDWORK ) +* + DO J = 1, N + DO I = 1, K + A( I, J ) = A( I, J ) - WORK( I, J ) + END DO + END DO +* + CALL DGEMM( 'N', 'N', M-L, N, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, B, LDB ) + CALL DGEMM( 'N', 'N', L, N, K-L, -ONE, V( MP, KP ), LDV, + $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) + CALL DTRMM( 'L', 'U', 'N', 'N', L, N, ONE, V( MP, 1 ), LDV, + $ WORK, LDWORK ) + DO J = 1, N + DO I = 1, L + B( M-L+I, J ) = B( M-L+I, J ) - WORK( I, J ) + END DO + END DO +* +* --------------------------------------------------------------------------- +* + ELSE IF( COLUMN .AND. FORWARD .AND. RIGHT ) THEN +* +* --------------------------------------------------------------------------- +* +* Let W = [ I ] (K-by-K) +* [ V ] (N-by-K) +* +* Form C H or C H**T where C = [ A B ] (A is M-by-K, B is M-by-N) +* +* H = I - W T W**T or H**T = I - W T**T W**T +* +* A = A - (A + B V) T or A = A - (A + B V) T**T +* B = B - (A + B V) T V**T or B = B - (A + B V) T**T V**T +* +* --------------------------------------------------------------------------- +* + NP = MIN( N-L+1, N ) + KP = MIN( L+1, K ) +* + DO J = 1, L + DO I = 1, M + WORK( I, J ) = B( I, N-L+J ) + END DO + END DO + CALL DTRMM( 'R', 'U', 'N', 'N', M, L, ONE, V( NP, 1 ), LDV, + $ WORK, LDWORK ) + CALL DGEMM( 'N', 'N', M, L, N-L, ONE, B, LDB, + $ V, LDV, ONE, WORK, LDWORK ) + CALL DGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, + $ V( 1, KP ), LDV, ZERO, WORK( 1, KP ), LDWORK ) +* + DO J = 1, K + DO I = 1, M + WORK( I, J ) = WORK( I, J ) + A( I, J ) + END DO + END DO +* + CALL DTRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, + $ WORK, LDWORK ) +* + DO J = 1, K + DO I = 1, M + A( I, J ) = A( I, J ) - WORK( I, J ) + END DO + END DO +* + CALL DGEMM( 'N', 'T', M, N-L, K, -ONE, WORK, LDWORK, + $ V, LDV, ONE, B, LDB ) + CALL DGEMM( 'N', 'T', M, L, K-L, -ONE, WORK( 1, KP ), LDWORK, + $ V( NP, KP ), LDV, ONE, B( 1, NP ), LDB ) + CALL DTRMM( 'R', 'U', 'T', 'N', M, L, ONE, V( NP, 1 ), LDV, + $ WORK, LDWORK ) + DO J = 1, L + DO I = 1, M + B( I, N-L+J ) = B( I, N-L+J ) - WORK( I, J ) + END DO + END DO +* +* --------------------------------------------------------------------------- +* + ELSE IF( COLUMN .AND. BACKWARD .AND. LEFT ) THEN +* +* --------------------------------------------------------------------------- +* +* Let W = [ V ] (M-by-K) +* [ I ] (K-by-K) +* +* Form H C or H**T C where C = [ B ] (M-by-N) +* [ A ] (K-by-N) +* +* H = I - W T W**T or H**T = I - W T**T W**T +* +* A = A - T (A + V**T B) or A = A - T**T (A + V**T B) +* B = B - V T (A + V**T B) or B = B - V T**T (A + V**T B) +* +* --------------------------------------------------------------------------- +* + MP = MIN( L+1, M ) + KP = MIN( K-L+1, K ) +* + DO J = 1, N + DO I = 1, L + WORK( K-L+I, J ) = B( I, J ) + END DO + END DO +* + CALL DTRMM( 'L', 'L', 'T', 'N', L, N, ONE, V( 1, KP ), LDV, + $ WORK( KP, 1 ), LDWORK ) + CALL DGEMM( 'T', 'N', L, N, M-L, ONE, V( MP, KP ), LDV, + $ B( MP, 1 ), LDB, ONE, WORK( KP, 1 ), LDWORK ) + CALL DGEMM( 'T', 'N', K-L, N, M, ONE, V, LDV, + $ B, LDB, ZERO, WORK, LDWORK ) +* + DO J = 1, N + DO I = 1, K + WORK( I, J ) = WORK( I, J ) + A( I, J ) + END DO + END DO +* + CALL DTRMM( 'L', 'L', TRANS, 'N', K, N, ONE, T, LDT, + $ WORK, LDWORK ) +* + DO J = 1, N + DO I = 1, K + A( I, J ) = A( I, J ) - WORK( I, J ) + END DO + END DO +* + CALL DGEMM( 'N', 'N', M-L, N, K, -ONE, V( MP, 1 ), LDV, + $ WORK, LDWORK, ONE, B( MP, 1 ), LDB ) + CALL DGEMM( 'N', 'N', L, N, K-L, -ONE, V, LDV, + $ WORK, LDWORK, ONE, B, LDB ) + CALL DTRMM( 'L', 'L', 'N', 'N', L, N, ONE, V( 1, KP ), LDV, + $ WORK( KP, 1 ), LDWORK ) + DO J = 1, N + DO I = 1, L + B( I, J ) = B( I, J ) - WORK( K-L+I, J ) + END DO + END DO +* +* --------------------------------------------------------------------------- +* + ELSE IF( COLUMN .AND. BACKWARD .AND. RIGHT ) THEN +* +* --------------------------------------------------------------------------- +* +* Let W = [ V ] (N-by-K) +* [ I ] (K-by-K) +* +* Form C H or C H**T where C = [ B A ] (B is M-by-N, A is M-by-K) +* +* H = I - W T W**T or H**T = I - W T**T W**T +* +* A = A - (A + B V) T or A = A - (A + B V) T**T +* B = B - (A + B V) T V**T or B = B - (A + B V) T**T V**T +* +* --------------------------------------------------------------------------- +* + NP = MIN( L+1, N ) + KP = MIN( K-L+1, K ) +* + DO J = 1, L + DO I = 1, M + WORK( I, K-L+J ) = B( I, J ) + END DO + END DO + CALL DTRMM( 'R', 'L', 'N', 'N', M, L, ONE, V( 1, KP ), LDV, + $ WORK( 1, KP ), LDWORK ) + CALL DGEMM( 'N', 'N', M, L, N-L, ONE, B( 1, NP ), LDB, + $ V( NP, KP ), LDV, ONE, WORK( 1, KP ), LDWORK ) + CALL DGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, + $ V, LDV, ZERO, WORK, LDWORK ) +* + DO J = 1, K + DO I = 1, M + WORK( I, J ) = WORK( I, J ) + A( I, J ) + END DO + END DO +* + CALL DTRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, + $ WORK, LDWORK ) +* + DO J = 1, K + DO I = 1, M + A( I, J ) = A( I, J ) - WORK( I, J ) + END DO + END DO +* + CALL DGEMM( 'N', 'T', M, N-L, K, -ONE, WORK, LDWORK, + $ V( NP, 1 ), LDV, ONE, B( 1, NP ), LDB ) + CALL DGEMM( 'N', 'T', M, L, K-L, -ONE, WORK, LDWORK, + $ V, LDV, ONE, B, LDB ) + CALL DTRMM( 'R', 'L', 'T', 'N', M, L, ONE, V( 1, KP ), LDV, + $ WORK( 1, KP ), LDWORK ) + DO J = 1, L + DO I = 1, M + B( I, J ) = B( I, J ) - WORK( I, K-L+J ) + END DO + END DO +* +* --------------------------------------------------------------------------- +* + ELSE IF( ROW .AND. FORWARD .AND. LEFT ) THEN +* +* --------------------------------------------------------------------------- +* +* Let W = [ I V ] ( I is K-by-K, V is K-by-M ) +* +* Form H C or H**T C where C = [ A ] (K-by-N) +* [ B ] (M-by-N) +* +* H = I - W**T T W or H**T = I - W**T T**T W +* +* A = A - T (A + V B) or A = A - T**T (A + V B) +* B = B - V**T T (A + V B) or B = B - V**T T**T (A + V B) +* +* --------------------------------------------------------------------------- +* + MP = MIN( M-L+1, M ) + KP = MIN( L+1, K ) +* + DO J = 1, N + DO I = 1, L + WORK( I, J ) = B( M-L+I, J ) + END DO + END DO + CALL DTRMM( 'L', 'L', 'N', 'N', L, N, ONE, V( 1, MP ), LDV, + $ WORK, LDB ) + CALL DGEMM( 'N', 'N', L, N, M-L, ONE, V, LDV,B, LDB, + $ ONE, WORK, LDWORK ) + CALL DGEMM( 'N', 'N', K-L, N, M, ONE, V( KP, 1 ), LDV, + $ B, LDB, ZERO, WORK( KP, 1 ), LDWORK ) +* + DO J = 1, N + DO I = 1, K + WORK( I, J ) = WORK( I, J ) + A( I, J ) + END DO + END DO +* + CALL DTRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, + $ WORK, LDWORK ) +* + DO J = 1, N + DO I = 1, K + A( I, J ) = A( I, J ) - WORK( I, J ) + END DO + END DO +* + CALL DGEMM( 'T', 'N', M-L, N, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, B, LDB ) + CALL DGEMM( 'T', 'N', L, N, K-L, -ONE, V( KP, MP ), LDV, + $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) + CALL DTRMM( 'L', 'L', 'T', 'N', L, N, ONE, V( 1, MP ), LDV, + $ WORK, LDWORK ) + DO J = 1, N + DO I = 1, L + B( M-L+I, J ) = B( M-L+I, J ) - WORK( I, J ) + END DO + END DO +* +* --------------------------------------------------------------------------- +* + ELSE IF( ROW .AND. FORWARD .AND. RIGHT ) THEN +* +* --------------------------------------------------------------------------- +* +* Let W = [ I V ] ( I is K-by-K, V is K-by-N ) +* +* Form C H or C H**T where C = [ A B ] (A is M-by-K, B is M-by-N) +* +* H = I - W**T T W or H**T = I - W**T T**T W +* +* A = A - (A + B V**T) T or A = A - (A + B V**T) T**T +* B = B - (A + B V**T) T V or B = B - (A + B V**T) T**T V +* +* --------------------------------------------------------------------------- +* + NP = MIN( N-L+1, N ) + KP = MIN( L+1, K ) +* + DO J = 1, L + DO I = 1, M + WORK( I, J ) = B( I, N-L+J ) + END DO + END DO + CALL DTRMM( 'R', 'L', 'T', 'N', M, L, ONE, V( 1, NP ), LDV, + $ WORK, LDWORK ) + CALL DGEMM( 'N', 'T', M, L, N-L, ONE, B, LDB, V, LDV, + $ ONE, WORK, LDWORK ) + CALL DGEMM( 'N', 'T', M, K-L, N, ONE, B, LDB, + $ V( KP, 1 ), LDV, ZERO, WORK( 1, KP ), LDWORK ) +* + DO J = 1, K + DO I = 1, M + WORK( I, J ) = WORK( I, J ) + A( I, J ) + END DO + END DO +* + CALL DTRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, + $ WORK, LDWORK ) +* + DO J = 1, K + DO I = 1, M + A( I, J ) = A( I, J ) - WORK( I, J ) + END DO + END DO +* + CALL DGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, + $ V, LDV, ONE, B, LDB ) + CALL DGEMM( 'N', 'N', M, L, K-L, -ONE, WORK( 1, KP ), LDWORK, + $ V( KP, NP ), LDV, ONE, B( 1, NP ), LDB ) + CALL DTRMM( 'R', 'L', 'N', 'N', M, L, ONE, V( 1, NP ), LDV, + $ WORK, LDWORK ) + DO J = 1, L + DO I = 1, M + B( I, N-L+J ) = B( I, N-L+J ) - WORK( I, J ) + END DO + END DO +* +* --------------------------------------------------------------------------- +* + ELSE IF( ROW .AND. BACKWARD .AND. LEFT ) THEN +* +* --------------------------------------------------------------------------- +* +* Let W = [ V I ] ( I is K-by-K, V is K-by-M ) +* +* Form H C or H**T C where C = [ B ] (M-by-N) +* [ A ] (K-by-N) +* +* H = I - W**T T W or H**T = I - W**T T**T W +* +* A = A - T (A + V B) or A = A - T**T (A + V B) +* B = B - V**T T (A + V B) or B = B - V**T T**T (A + V B) +* +* --------------------------------------------------------------------------- +* + MP = MIN( L+1, M ) + KP = MIN( K-L+1, K ) +* + DO J = 1, N + DO I = 1, L + WORK( K-L+I, J ) = B( I, J ) + END DO + END DO + CALL DTRMM( 'L', 'U', 'N', 'N', L, N, ONE, V( KP, 1 ), LDV, + $ WORK( KP, 1 ), LDWORK ) + CALL DGEMM( 'N', 'N', L, N, M-L, ONE, V( KP, MP ), LDV, + $ B( MP, 1 ), LDB, ONE, WORK( KP, 1 ), LDWORK ) + CALL DGEMM( 'N', 'N', K-L, N, M, ONE, V, LDV, B, LDB, + $ ZERO, WORK, LDWORK ) +* + DO J = 1, N + DO I = 1, K + WORK( I, J ) = WORK( I, J ) + A( I, J ) + END DO + END DO +* + CALL DTRMM( 'L', 'L ', TRANS, 'N', K, N, ONE, T, LDT, + $ WORK, LDWORK ) +* + DO J = 1, N + DO I = 1, K + A( I, J ) = A( I, J ) - WORK( I, J ) + END DO + END DO +* + CALL DGEMM( 'T', 'N', M-L, N, K, -ONE, V( 1, MP ), LDV, + $ WORK, LDWORK, ONE, B( MP, 1 ), LDB ) + CALL DGEMM( 'T', 'N', L, N, K-L, -ONE, V, LDV, + $ WORK, LDWORK, ONE, B, LDB ) + CALL DTRMM( 'L', 'U', 'T', 'N', L, N, ONE, V( KP, 1 ), LDV, + $ WORK( KP, 1 ), LDWORK ) + DO J = 1, N + DO I = 1, L + B( I, J ) = B( I, J ) - WORK( K-L+I, J ) + END DO + END DO +* +* --------------------------------------------------------------------------- +* + ELSE IF( ROW .AND. BACKWARD .AND. RIGHT ) THEN +* +* --------------------------------------------------------------------------- +* +* Let W = [ V I ] ( I is K-by-K, V is K-by-N ) +* +* Form C H or C H**T where C = [ B A ] (A is M-by-K, B is M-by-N) +* +* H = I - W**T T W or H**T = I - W**T T**T W +* +* A = A - (A + B V**T) T or A = A - (A + B V**T) T**T +* B = B - (A + B V**T) T V or B = B - (A + B V**T) T**T V +* +* --------------------------------------------------------------------------- +* + NP = MIN( L+1, N ) + KP = MIN( K-L+1, K ) +* + DO J = 1, L + DO I = 1, M + WORK( I, K-L+J ) = B( I, J ) + END DO + END DO + CALL DTRMM( 'R', 'U', 'T', 'N', M, L, ONE, V( KP, 1 ), LDV, + $ WORK( 1, KP ), LDWORK ) + CALL DGEMM( 'N', 'T', M, L, N-L, ONE, B( 1, NP ), LDB, + $ V( KP, NP ), LDV, ONE, WORK( 1, KP ), LDWORK ) + CALL DGEMM( 'N', 'T', M, K-L, N, ONE, B, LDB, V, LDV, + $ ZERO, WORK, LDWORK ) +* + DO J = 1, K + DO I = 1, M + WORK( I, J ) = WORK( I, J ) + A( I, J ) + END DO + END DO +* + CALL DTRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, + $ WORK, LDWORK ) +* + DO J = 1, K + DO I = 1, M + A( I, J ) = A( I, J ) - WORK( I, J ) + END DO + END DO +* + CALL DGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, + $ V( 1, NP ), LDV, ONE, B( 1, NP ), LDB ) + CALL DGEMM( 'N', 'N', M, L, K-L , -ONE, WORK, LDWORK, + $ V, LDV, ONE, B, LDB ) + CALL DTRMM( 'R', 'U', 'N', 'N', M, L, ONE, V( KP, 1 ), LDV, + $ WORK( 1, KP ), LDWORK ) + DO J = 1, L + DO I = 1, M + B( I, J ) = B( I, J ) - WORK( I, K-L+J ) + END DO + END DO +* + END IF +* + RETURN +* +* End of DTPRFB +* + END diff --git a/math/lapack/src/main/fortran/dtprfs.f b/math/lapack/src/main/fortran/dtprfs.f new file mode 100644 index 0000000000..2dc427e459 --- /dev/null +++ b/math/lapack/src/main/fortran/dtprfs.f @@ -0,0 +1,473 @@ +*> \brief \b DTPRFS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, +* FERR, BERR, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, TRANS, UPLO +* INTEGER INFO, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION AP( * ), B( LDB, * ), BERR( * ), FERR( * ), +* $ WORK( * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPRFS provides error bounds and backward error estimates for the +*> solution to a system of linear equations with a triangular packed +*> coefficient matrix. +*> +*> The solution matrix X must be computed by DTPTRS or some other +*> means before entering this routine. DTPRFS does not do iterative +*> refinement because doing so cannot improve the backward error. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> = 'N': A is non-unit triangular; +*> = 'U': A is unit triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> The upper or lower triangular matrix A, packed columnwise in +*> a linear array. The j-th column of A is stored in the array +*> AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. +*> If DIAG = 'U', the diagonal elements of A are not referenced +*> and are assumed to be 1. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> The solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, + $ FERR, BERR, WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, TRANS, UPLO + INTEGER INFO, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AP( * ), B( LDB, * ), BERR( * ), FERR( * ), + $ WORK( * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN, NOUNIT, UPPER + CHARACTER TRANST + INTEGER I, J, K, KASE, KC, NZ + DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLACN2, DTPMV, DTPSV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + NOTRAN = LSAME( TRANS, 'N' ) + NOUNIT = LSAME( DIAG, 'N' ) +* + 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( N.LT.0 ) THEN + INFO = -4 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPRFS', -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 250 J = 1, NRHS +* +* Compute residual R = B - op(A) * X, +* where op(A) = A or A**T, depending on TRANS. +* + CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 ) + CALL DTPMV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 ) + CALL DAXPY( N, -ONE, B( 1, J ), 1, 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 20 I = 1, N + WORK( I ) = ABS( B( I, J ) ) + 20 CONTINUE +* + IF( NOTRAN ) THEN +* +* Compute abs(A)*abs(X) + abs(B). +* + IF( UPPER ) THEN + KC = 1 + IF( NOUNIT ) THEN + DO 40 K = 1, N + XK = ABS( X( K, J ) ) + DO 30 I = 1, K + WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK + 30 CONTINUE + KC = KC + K + 40 CONTINUE + ELSE + DO 60 K = 1, N + XK = ABS( X( K, J ) ) + DO 50 I = 1, K - 1 + WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK + 50 CONTINUE + WORK( K ) = WORK( K ) + XK + KC = KC + K + 60 CONTINUE + END IF + ELSE + KC = 1 + IF( NOUNIT ) THEN + DO 80 K = 1, N + XK = ABS( X( K, J ) ) + DO 70 I = K, N + WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK + 70 CONTINUE + KC = KC + N - K + 1 + 80 CONTINUE + ELSE + DO 100 K = 1, N + XK = ABS( X( K, J ) ) + DO 90 I = K + 1, N + WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK + 90 CONTINUE + WORK( K ) = WORK( K ) + XK + KC = KC + N - K + 1 + 100 CONTINUE + END IF + END IF + ELSE +* +* Compute abs(A**T)*abs(X) + abs(B). +* + IF( UPPER ) THEN + KC = 1 + IF( NOUNIT ) THEN + DO 120 K = 1, N + S = ZERO + DO 110 I = 1, K + S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) ) + 110 CONTINUE + WORK( K ) = WORK( K ) + S + KC = KC + K + 120 CONTINUE + ELSE + DO 140 K = 1, N + S = ABS( X( K, J ) ) + DO 130 I = 1, K - 1 + S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) ) + 130 CONTINUE + WORK( K ) = WORK( K ) + S + KC = KC + K + 140 CONTINUE + END IF + ELSE + KC = 1 + IF( NOUNIT ) THEN + DO 160 K = 1, N + S = ZERO + DO 150 I = K, N + S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) ) + 150 CONTINUE + WORK( K ) = WORK( K ) + S + KC = KC + N - K + 1 + 160 CONTINUE + ELSE + DO 180 K = 1, N + S = ABS( X( K, J ) ) + DO 170 I = K + 1, N + S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) ) + 170 CONTINUE + WORK( K ) = WORK( K ) + S + KC = KC + N - K + 1 + 180 CONTINUE + END IF + END IF + END IF + S = ZERO + DO 190 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 + 190 CONTINUE + BERR( J ) = S +* +* Bound error from formula +* +* norm(X - XTRUE) / norm(X) .le. FERR = +* norm( abs(inv(op(A)))* +* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) +* +* where +* norm(Z) is the magnitude of the largest component of Z +* inv(op(A)) is the inverse of op(A) +* abs(Z) is the componentwise absolute value of the matrix or +* vector Z +* NZ is the maximum number of nonzeros in any row of A, plus 1 +* EPS is machine epsilon +* +* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) +* is incremented by SAFE1 if the i-th component of +* abs(op(A))*abs(X) + abs(B) is less than SAFE2. +* +* Use DLACN2 to estimate the infinity-norm of the matrix +* inv(op(A)) * diag(W), +* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) +* + DO 200 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 + 200 CONTINUE +* + KASE = 0 + 210 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 DTPSV( UPLO, TRANST, DIAG, N, AP, WORK( N+1 ), 1 ) + DO 220 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 220 CONTINUE + ELSE +* +* Multiply by inv(op(A))*diag(W). +* + DO 230 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 230 CONTINUE + CALL DTPSV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 ) + END IF + GO TO 210 + END IF +* +* Normalize error. +* + LSTRES = ZERO + DO 240 I = 1, N + LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) + 240 CONTINUE + IF( LSTRES.NE.ZERO ) + $ FERR( J ) = FERR( J ) / LSTRES +* + 250 CONTINUE +* + RETURN +* +* End of DTPRFS +* + END diff --git a/math/lapack/src/main/fortran/dtptri.f b/math/lapack/src/main/fortran/dtptri.f new file mode 100644 index 0000000000..32f38344ec --- /dev/null +++ b/math/lapack/src/main/fortran/dtptri.f @@ -0,0 +1,241 @@ +*> \brief \b DTPTRI +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, UPLO +* INTEGER INFO, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPTRI computes the inverse of a real upper or lower triangular +*> matrix A stored in packed format. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> = 'N': A is non-unit triangular; +*> = 'U': A is unit triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> On entry, the upper or lower triangular matrix A, stored +*> columnwise in a linear array. The j-th column of A is stored +*> in the array AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n. +*> See below for further details. +*> On exit, the (triangular) inverse of the original matrix, in +*> the same packed storage format. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, A(i,i) is exactly zero. The triangular +*> matrix is singular and its inverse can not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> A triangular matrix A can be transferred to packed storage using one +*> of the following program segments: +*> +*> UPLO = 'U': UPLO = 'L': +*> +*> JC = 1 JC = 1 +*> DO 2 J = 1, N DO 2 J = 1, N +*> DO 1 I = 1, J DO 1 I = J, N +*> AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) +*> 1 CONTINUE 1 CONTINUE +*> JC = JC + J JC = JC + N - J + 1 +*> 2 CONTINUE 2 CONTINUE +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT, UPPER + INTEGER J, JC, JCLAST, JJ + DOUBLE PRECISION AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DTPMV, XERBLA +* .. +* .. 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 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPTRI', -INFO ) + RETURN + END IF +* +* Check for singularity if non-unit. +* + IF( NOUNIT ) THEN + IF( UPPER ) THEN + JJ = 0 + DO 10 INFO = 1, N + JJ = JJ + INFO + IF( AP( JJ ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + ELSE + JJ = 1 + DO 20 INFO = 1, N + IF( AP( JJ ).EQ.ZERO ) + $ RETURN + JJ = JJ + N - INFO + 1 + 20 CONTINUE + END IF + INFO = 0 + END IF +* + IF( UPPER ) THEN +* +* Compute inverse of upper triangular matrix. +* + JC = 1 + DO 30 J = 1, N + IF( NOUNIT ) THEN + AP( JC+J-1 ) = ONE / AP( JC+J-1 ) + AJJ = -AP( JC+J-1 ) + ELSE + AJJ = -ONE + END IF +* +* Compute elements 1:j-1 of j-th column. +* + CALL DTPMV( 'Upper', 'No transpose', DIAG, J-1, AP, + $ AP( JC ), 1 ) + CALL DSCAL( J-1, AJJ, AP( JC ), 1 ) + JC = JC + J + 30 CONTINUE +* + ELSE +* +* Compute inverse of lower triangular matrix. +* + JC = N*( N+1 ) / 2 + DO 40 J = N, 1, -1 + IF( NOUNIT ) THEN + AP( JC ) = ONE / AP( JC ) + AJJ = -AP( JC ) + ELSE + AJJ = -ONE + END IF + IF( J.LT.N ) THEN +* +* Compute elements j+1:n of j-th column. +* + CALL DTPMV( 'Lower', 'No transpose', DIAG, N-J, + $ AP( JCLAST ), AP( JC+1 ), 1 ) + CALL DSCAL( N-J, AJJ, AP( JC+1 ), 1 ) + END IF + JCLAST = JC + JC = JC - N + J - 2 + 40 CONTINUE + END IF +* + RETURN +* +* End of DTPTRI +* + END diff --git a/math/lapack/src/main/fortran/dtptrs.f b/math/lapack/src/main/fortran/dtptrs.f new file mode 100644 index 0000000000..c62724128f --- /dev/null +++ b/math/lapack/src/main/fortran/dtptrs.f @@ -0,0 +1,228 @@ +*> \brief \b DTPTRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, TRANS, UPLO +* INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPTRS solves a triangular system of the form +*> +*> A * X = B or A**T * X = B, +*> +*> where A is a triangular matrix of order N stored in packed format, +*> and B is an N-by-NRHS matrix. A check is made to verify that A is +*> nonsingular. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> = 'N': A is non-unit triangular; +*> = 'U': A is unit triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) +*> The upper or lower triangular matrix A, packed columnwise in +*> a linear array. The j-th column of A is stored in the array +*> AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, if INFO = 0, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, TRANS, UPLO + INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT, UPPER + INTEGER J, JC +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DTPSV, 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.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( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Check for singularity. +* + IF( NOUNIT ) THEN + IF( UPPER ) THEN + JC = 1 + DO 10 INFO = 1, N + IF( AP( JC+INFO-1 ).EQ.ZERO ) + $ RETURN + JC = JC + INFO + 10 CONTINUE + ELSE + JC = 1 + DO 20 INFO = 1, N + IF( AP( JC ).EQ.ZERO ) + $ RETURN + JC = JC + N - INFO + 1 + 20 CONTINUE + END IF + END IF + INFO = 0 +* +* Solve A * x = b or A**T * x = b. +* + DO 30 J = 1, NRHS + CALL DTPSV( UPLO, TRANS, DIAG, N, AP, B( 1, J ), 1 ) + 30 CONTINUE +* + RETURN +* +* End of DTPTRS +* + END diff --git a/math/lapack/src/main/fortran/dtpttf.f b/math/lapack/src/main/fortran/dtpttf.f new file mode 100644 index 0000000000..a37a3e30a1 --- /dev/null +++ b/math/lapack/src/main/fortran/dtpttf.f @@ -0,0 +1,502 @@ +*> \brief \b DTPTTF copies a triangular matrix from the standard packed format (TP) to the rectangular full packed format (TF). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPTTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANSR, UPLO +* INTEGER INFO, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( 0: * ), ARF( 0: * ) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPTTF copies a triangular matrix A from standard packed format (TP) +*> to rectangular full packed format (TF). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSR +*> \verbatim +*> TRANSR is CHARACTER*1 +*> = 'N': ARF in Normal format is wanted; +*> = 'T': ARF in Conjugate-transpose format is wanted. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), +*> On entry, the upper or lower triangular matrix A, packed +*> columnwise in a linear array. The j-th column of A is stored +*> in the array AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +*> \endverbatim +*> +*> \param[out] ARF +*> \verbatim +*> ARF is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), +*> On exit, the upper or lower triangular matrix A stored in +*> RFP format. For a further discussion see Notes below. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> We first consider Rectangular Full Packed (RFP) Format when N is +*> even. We give an example where N = 6. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 05 00 +*> 11 12 13 14 15 10 11 +*> 22 23 24 25 20 21 22 +*> 33 34 35 30 31 32 33 +*> 44 45 40 41 42 43 44 +*> 55 50 51 52 53 54 55 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(4:6,0:2) consists of +*> the transpose of the first three columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:2,0:2) consists of +*> the transpose of the last three columns of AP lower. +*> This covers the case N even and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 03 04 05 33 43 53 +*> 13 14 15 00 44 54 +*> 23 24 25 10 11 55 +*> 33 34 35 20 21 22 +*> 00 44 45 30 31 32 +*> 01 11 55 40 41 42 +*> 02 12 22 50 51 52 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> +*> RFP A RFP A +*> +*> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +*> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +*> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +*> +*> +*> We then consider Rectangular Full Packed (RFP) Format when N is +*> odd. We give an example where N = 5. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 00 +*> 11 12 13 14 10 11 +*> 22 23 24 20 21 22 +*> 33 34 30 31 32 33 +*> 44 40 41 42 43 44 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(3:4,0:1) consists of +*> the transpose of the first two columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:1,1:2) consists of +*> the transpose of the last two columns of AP lower. +*> This covers the case N odd and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 02 03 04 00 33 43 +*> 12 13 14 10 11 44 +*> 22 23 24 20 21 22 +*> 00 33 34 30 31 32 +*> 01 11 44 40 41 42 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> RFP A RFP A +*> +*> 02 12 22 00 01 00 10 20 30 40 50 +*> 03 13 23 33 11 33 11 21 31 41 51 +*> 04 14 24 34 44 43 44 22 32 42 52 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( 0: * ), ARF( 0: * ) +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K, NT + INTEGER I, J, IJ + INTEGER IJP, JP, LDA, JS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPTTF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( NORMALTRANSR ) THEN + ARF( 0 ) = AP( 0 ) + ELSE + ARF( 0 ) = AP( 0 ) + END IF + RETURN + END IF +* +* Size of array ARF(0:NT-1) +* + NT = N*( N+1 ) / 2 +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* +* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) +* where noe = 0 if n is even, noe = 1 if n is odd +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + LDA = N + 1 + ELSE + NISODD = .TRUE. + LDA = N + END IF +* +* ARF^C has lda rows and n+1-noe cols +* + IF( .NOT.NORMALTRANSR ) + $ LDA = ( N+1 ) / 2 +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'N', and UPLO = 'L' +* + IJP = 0 + JP = 0 + DO J = 0, N2 + DO I = J, N - 1 + IJ = I + JP + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, N2 - 1 + DO J = 1 + I, N2 + IJ = I + J*LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* N is odd, TRANSR = 'N', and UPLO = 'U' +* + IJP = 0 + DO J = 0, N1 - 1 + IJ = N2 + J + DO I = 0, J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = N1, N - 1 + IJ = JS + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'T', and UPLO = 'L' +* + IJP = 0 + DO I = 0, N2 + DO IJ = I*( LDA+1 ), N*LDA - 1, LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO + JS = 1 + DO J = 0, N2 - 1 + DO IJ = JS, JS + N2 - J - 1 + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* N is odd, TRANSR = 'T', and UPLO = 'U' +* + IJP = 0 + JS = N2*LDA + DO J = 0, N1 - 1 + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, N1 + DO IJ = I, I + ( N1+I )*LDA, LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'N', and UPLO = 'L' +* + IJP = 0 + JP = 0 + DO J = 0, K - 1 + DO I = J, N - 1 + IJ = 1 + I + JP + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, K - 1 + DO J = I, K - 1 + IJ = I + J*LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* N is even, TRANSR = 'N', and UPLO = 'U' +* + IJP = 0 + DO J = 0, K - 1 + IJ = K + 1 + J + DO I = 0, J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = K, N - 1 + IJ = JS + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'T', and UPLO = 'L' +* + IJP = 0 + DO I = 0, K - 1 + DO IJ = I + ( I+1 )*LDA, ( N+1 )*LDA - 1, LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO + JS = 0 + DO J = 0, K - 1 + DO IJ = JS, JS + K - J - 1 + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* N is even, TRANSR = 'T', and UPLO = 'U' +* + IJP = 0 + JS = ( K+1 )*LDA + DO J = 0, K - 1 + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, K - 1 + DO IJ = I, I + ( K+I )*LDA, LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of DTPTTF +* + END diff --git a/math/lapack/src/main/fortran/dtpttr.f b/math/lapack/src/main/fortran/dtpttr.f new file mode 100644 index 0000000000..6258179938 --- /dev/null +++ b/math/lapack/src/main/fortran/dtpttr.f @@ -0,0 +1,176 @@ +*> \brief \b DTPTTR copies a triangular matrix from the standard packed format (TP) to the standard full format (TR). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPTTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPTTR( UPLO, N, AP, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, N, LDA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), AP( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPTTR copies a triangular matrix A from standard packed format (TP) +*> to standard full format (TR). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular. +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), +*> On entry, the upper or lower triangular matrix A, packed +*> columnwise in a linear array. The j-th column of A is stored +*> in the array AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) +*> On exit, the triangular matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DTPTTR( UPLO, N, AP, A, LDA, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), AP( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER + INTEGER I, J, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPTTR', -INFO ) + RETURN + END IF +* + IF( LOWER ) THEN + K = 0 + DO J = 1, N + DO I = J, N + K = K + 1 + A( I, J ) = AP( K ) + END DO + END DO + ELSE + K = 0 + DO J = 1, N + DO I = 1, J + K = K + 1 + A( I, J ) = AP( K ) + END DO + END DO + END IF +* +* + RETURN +* +* End of DTPTTR +* + END diff --git a/math/lapack/src/main/fortran/dtrcon.f b/math/lapack/src/main/fortran/dtrcon.f new file mode 100644 index 0000000000..ad40d3774a --- /dev/null +++ b/math/lapack/src/main/fortran/dtrcon.f @@ -0,0 +1,276 @@ +*> \brief \b DTRCON +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTRCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, +* IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, NORM, UPLO +* INTEGER INFO, LDA, N +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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)) ). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is 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. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> = 'N': A is non-unit triangular; +*> = 'U': A is unit triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(norm(A) * norm(inv(A))). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, + $ IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, NORM, UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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**T). +* + 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/math/lapack/src/main/fortran/dtrevc.f b/math/lapack/src/main/fortran/dtrevc.f new file mode 100644 index 0000000000..921f5143ac --- /dev/null +++ b/math/lapack/src/main/fortran/dtrevc.f @@ -0,0 +1,1076 @@ +*> \brief \b DTREVC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTREVC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, +* LDVR, MM, M, WORK, INFO ) +* +* .. 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( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'R': compute right eigenvectors only; +*> = 'L': compute left eigenvectors only; +*> = 'B': compute both right and left eigenvectors. +*> \endverbatim +*> +*> \param[in] HOWMNY +*> \verbatim +*> HOWMNY is 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. +*> \endverbatim +*> +*> \param[in,out] SELECT +*> \verbatim +*> SELECT is 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'. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> The upper quasi-triangular matrix T in Schur canonical form. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is 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'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the array VL. LDVL >= 1, and if +*> SIDE = 'L' or 'B', LDVL >= N. +*> \endverbatim +*> +*> \param[in,out] VR +*> \verbatim +*> VR is 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'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. LDVR >= 1, and if +*> SIDE = 'R' or 'B', LDVR >= N. +*> \endverbatim +*> +*> \param[in] MM +*> \verbatim +*> MM is INTEGER +*> The number of columns in the arrays VL and/or VR. MM >= M. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is 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. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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|. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + $ LDVR, MM, M, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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( * ) +* .. +* +* ===================================================================== +* +* .. 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)**T*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)**T*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) ]**T * 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) )**T - (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) ]**T-(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/math/lapack/src/main/fortran/dtrevc3.f b/math/lapack/src/main/fortran/dtrevc3.f new file mode 100644 index 0000000000..e6c0f2ffba --- /dev/null +++ b/math/lapack/src/main/fortran/dtrevc3.f @@ -0,0 +1,1304 @@ +*> \brief \b DTREVC3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTREVC3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, +* VR, LDVR, MM, M, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER HOWMNY, SIDE +* INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N +* .. +* .. Array Arguments .. +* LOGICAL SELECT( * ) +* DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTREVC3 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. +*> +*> This uses a Level 3 BLAS version of the back transformation. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'R': compute right eigenvectors only; +*> = 'L': compute left eigenvectors only; +*> = 'B': compute both right and left eigenvectors. +*> \endverbatim +*> +*> \param[in] HOWMNY +*> \verbatim +*> HOWMNY is 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. +*> \endverbatim +*> +*> \param[in,out] SELECT +*> \verbatim +*> SELECT is 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'. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> The upper quasi-triangular matrix T in Schur canonical form. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is 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'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the array VL. +*> LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N. +*> \endverbatim +*> +*> \param[in,out] VR +*> \verbatim +*> VR is 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'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. +*> LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N. +*> \endverbatim +*> +*> \param[in] MM +*> \verbatim +*> MM is INTEGER +*> The number of columns in the arrays VL and/or VR. MM >= M. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is 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. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of array WORK. LWORK >= max(1,3*N). +*> For optimum performance, LWORK >= N + 2*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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +* @precisions fortran d -> s +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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|. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, + $ VR, LDVR, MM, M, WORK, LWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER HOWMNY, SIDE + INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER NBMIN, NBMAX + PARAMETER ( NBMIN = 8, NBMAX = 128 ) +* .. +* .. Local Scalars .. + LOGICAL ALLV, BOTHV, LEFTV, LQUERY, OVER, PAIR, + $ RIGHTV, SOMEV + INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, + $ IV, MAXWRK, NB, KI2 + DOUBLE PRECISION BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE, + $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR, + $ XNORM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL LSAME, IDAMAX, ILAENV, DDOT, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DLALN2, DSCAL, XERBLA, + $ DGEMM, DLASET, DLABAD +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Local Arrays .. + DOUBLE PRECISION X( 2, 2 ) + INTEGER ISCOMPLEX( NBMAX ) +* .. +* .. 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 + NB = ILAENV( 1, 'DTREVC', SIDE // HOWMNY, N, -1, -1, -1 ) + MAXWRK = N + 2*N*NB + WORK(1) = MAXWRK + LQUERY = ( LWORK.EQ.-1 ) + 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( LWORK.LT.MAX( 1, 3*N ) .AND. .NOT.LQUERY ) THEN + INFO = -14 + 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( 'DTREVC3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* +* Use blocked version of back-transformation if sufficient workspace. +* Zero-out the workspace to avoid potential NaN propagation. +* + IF( OVER .AND. LWORK .GE. N + 2*N*NBMIN ) THEN + NB = (LWORK - N) / (2*N) + NB = MIN( NB, NBMAX ) + CALL DLASET( 'F', N, 1+2*NB, ZERO, ZERO, WORK, N ) + ELSE + NB = 1 + END IF +* +* 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) +* ISCOMPLEX array stores IP for each column in current block. +* + IF( RIGHTV ) THEN +* +* ============================================================ +* Compute right eigenvectors. +* +* IV is index of column in current block. +* For complex right vector, uses IV-1 for real part and IV for complex part. +* Non-blocked version always uses IV=2; +* blocked version starts with IV=NB, goes down to 1 or 2. +* (Note the "0-th" column is used for 1-norms computed above.) + IV = 2 + IF( NB.GT.2 ) THEN + IV = NB + END IF + + IP = 0 + IS = M + DO 140 KI = N, 1, -1 + IF( IP.EQ.-1 ) THEN +* previous iteration (ki+1) was second of conjugate pair, +* so this ki is first of conjugate pair; skip to end of loop + IP = 1 + GO TO 140 + ELSE IF( KI.EQ.1 ) THEN +* last column, so this ki must be real eigenvalue + IP = 0 + ELSE IF( T( KI, KI-1 ).EQ.ZERO ) THEN +* zero on sub-diagonal, so this ki is real eigenvalue + IP = 0 + ELSE +* non-zero on sub-diagonal, so this ki is second of conjugate pair + IP = -1 + END IF + + IF( SOMEV ) THEN + IF( IP.EQ.0 ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 140 + ELSE + IF( .NOT.SELECT( KI-1 ) ) + $ GO TO 140 + 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 + IV*N ) = ONE +* +* Form right-hand side. +* + DO 50 K = 1, KI - 1 + WORK( K + IV*N ) = -T( K, KI ) + 50 CONTINUE +* +* Solve 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+IV*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+IV*N ), 1 ) + WORK( J+IV*N ) = X( 1, 1 ) +* +* Update right-hand side +* + CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, + $ WORK( 1+IV*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+IV*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+IV*N ), 1 ) + WORK( J-1+IV*N ) = X( 1, 1 ) + WORK( J +IV*N ) = X( 2, 1 ) +* +* Update right-hand side +* + CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, + $ WORK( 1+IV*N ), 1 ) + CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, + $ WORK( 1+IV*N ), 1 ) + END IF + 60 CONTINUE +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN +* ------------------------------ +* no back-transform: copy x to VR and normalize. + CALL DCOPY( KI, WORK( 1 + IV*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( NB.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( KI.GT.1 ) + $ CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR, + $ WORK( 1 + IV*N ), 1, WORK( KI + IV*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 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out below vector + DO K = KI + 1, N + WORK( K + IV*N ) = ZERO + END DO + ISCOMPLEX( IV ) = IP +* back-transform and normalization is done below + 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 + (IV-1)*N ) = ONE + WORK( KI + (IV )*N ) = WI / T( KI-1, KI ) + ELSE + WORK( KI-1 + (IV-1)*N ) = -WI / T( KI, KI-1 ) + WORK( KI + (IV )*N ) = ONE + END IF + WORK( KI + (IV-1)*N ) = ZERO + WORK( KI-1 + (IV )*N ) = ZERO +* +* Form right-hand side. +* + DO 80 K = 1, KI - 2 + WORK( K+(IV-1)*N ) = -WORK( KI-1+(IV-1)*N )*T(K,KI-1) + WORK( K+(IV )*N ) = -WORK( KI +(IV )*N )*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+(IV-1)*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+(IV-1)*N ), 1 ) + CALL DSCAL( KI, SCALE, WORK( 1+(IV )*N ), 1 ) + END IF + WORK( J+(IV-1)*N ) = X( 1, 1 ) + WORK( J+(IV )*N ) = X( 1, 2 ) +* +* Update the right-hand side +* + CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, + $ WORK( 1+(IV-1)*N ), 1 ) + CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1, + $ WORK( 1+(IV )*N ), 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+(IV-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+(IV-1)*N ), 1 ) + CALL DSCAL( KI, SCALE, WORK( 1+(IV )*N ), 1 ) + END IF + WORK( J-1+(IV-1)*N ) = X( 1, 1 ) + WORK( J +(IV-1)*N ) = X( 2, 1 ) + WORK( J-1+(IV )*N ) = X( 1, 2 ) + WORK( J +(IV )*N ) = X( 2, 2 ) +* +* Update the right-hand side +* + CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, + $ WORK( 1+(IV-1)*N ), 1 ) + CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, + $ WORK( 1+(IV-1)*N ), 1 ) + CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1, + $ WORK( 1+(IV )*N ), 1 ) + CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, + $ WORK( 1+(IV )*N ), 1 ) + END IF + 90 CONTINUE +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN +* ------------------------------ +* no back-transform: copy x to VR and normalize. + CALL DCOPY( KI, WORK( 1+(IV-1)*N ), 1, VR(1,IS-1), 1 ) + CALL DCOPY( KI, WORK( 1+(IV )*N ), 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( NB.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( KI.GT.2 ) THEN + CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, + $ WORK( 1 + (IV-1)*N ), 1, + $ WORK( KI-1 + (IV-1)*N ), VR(1,KI-1), 1) + CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, + $ WORK( 1 + (IV)*N ), 1, + $ WORK( KI + (IV)*N ), VR( 1, KI ), 1 ) + ELSE + CALL DSCAL( N, WORK(KI-1+(IV-1)*N), VR(1,KI-1), 1) + CALL DSCAL( N, WORK(KI +(IV )*N), 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 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out below vector + DO K = KI + 1, N + WORK( K + (IV-1)*N ) = ZERO + WORK( K + (IV )*N ) = ZERO + END DO + ISCOMPLEX( IV-1 ) = -IP + ISCOMPLEX( IV ) = IP + IV = IV - 1 +* back-transform and normalization is done below + END IF + END IF + + IF( NB.GT.1 ) THEN +* -------------------------------------------------------- +* Blocked version of back-transform +* For complex case, KI2 includes both vectors (KI-1 and KI) + IF( IP.EQ.0 ) THEN + KI2 = KI + ELSE + KI2 = KI - 1 + END IF + +* Columns IV:NB of work are valid vectors. +* When the number of vectors stored reaches NB-1 or NB, +* or if this was last vector, do the GEMM + IF( (IV.LE.2) .OR. (KI2.EQ.1) ) THEN + CALL DGEMM( 'N', 'N', N, NB-IV+1, KI2+NB-IV, ONE, + $ VR, LDVR, + $ WORK( 1 + (IV)*N ), N, + $ ZERO, + $ WORK( 1 + (NB+IV)*N ), N ) +* normalize vectors + DO K = IV, NB + IF( ISCOMPLEX(K).EQ.0 ) THEN +* real eigenvector + II = IDAMAX( N, WORK( 1 + (NB+K)*N ), 1 ) + REMAX = ONE / ABS( WORK( II + (NB+K)*N ) ) + ELSE IF( ISCOMPLEX(K).EQ.1 ) THEN +* first eigenvector of conjugate pair + EMAX = ZERO + DO II = 1, N + EMAX = MAX( EMAX, + $ ABS( WORK( II + (NB+K )*N ) )+ + $ ABS( WORK( II + (NB+K+1)*N ) ) ) + END DO + REMAX = ONE / EMAX +* else if ISCOMPLEX(K).EQ.-1 +* second eigenvector of conjugate pair +* reuse same REMAX as previous K + END IF + CALL DSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 ) + END DO + CALL DLACPY( 'F', N, NB-IV+1, + $ WORK( 1 + (NB+IV)*N ), N, + $ VR( 1, KI2 ), LDVR ) + IV = NB + ELSE + IV = IV - 1 + END IF + END IF ! blocked back-transform +* + IS = IS - 1 + IF( IP.NE.0 ) + $ IS = IS - 1 + 140 CONTINUE + END IF + + IF( LEFTV ) THEN +* +* ============================================================ +* Compute left eigenvectors. +* +* IV is index of column in current block. +* For complex left vector, uses IV for real part and IV+1 for complex part. +* Non-blocked version always uses IV=1; +* blocked version starts with IV=1, goes up to NB-1 or NB. +* (Note the "0-th" column is used for 1-norms computed above.) + IV = 1 + IP = 0 + IS = 1 + DO 260 KI = 1, N + IF( IP.EQ.1 ) THEN +* previous iteration (ki-1) was first of conjugate pair, +* so this ki is second of conjugate pair; skip to end of loop + IP = -1 + GO TO 260 + ELSE IF( KI.EQ.N ) THEN +* last column, so this ki must be real eigenvalue + IP = 0 + ELSE IF( T( KI+1, KI ).EQ.ZERO ) THEN +* zero on sub-diagonal, so this ki is real eigenvalue + IP = 0 + ELSE +* non-zero on sub-diagonal, so this ki is first of conjugate pair + IP = 1 + END IF +* + IF( SOMEV ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 260 + 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 + IV*N ) = ONE +* +* Form right-hand side. +* + DO 160 K = KI + 1, N + WORK( K + IV*N ) = -T( KI, K ) + 160 CONTINUE +* +* Solve transposed quasi-triangular system: +* [ T(KI+1:N,KI+1:N) - WR ]**T * 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+IV*N ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+IV*N ) = WORK( J+IV*N ) - + $ DDOT( J-KI-1, T( KI+1, J ), 1, + $ WORK( KI+1+IV*N ), 1 ) +* +* Solve [ T(J,J) - WR ]**T * X = WORK +* + CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+IV*N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+IV*N ), 1 ) + WORK( J+IV*N ) = X( 1, 1 ) + VMAX = MAX( ABS( WORK( J+IV*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+IV*N ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+IV*N ) = WORK( J+IV*N ) - + $ DDOT( J-KI-1, T( KI+1, J ), 1, + $ WORK( KI+1+IV*N ), 1 ) +* + WORK( J+1+IV*N ) = WORK( J+1+IV*N ) - + $ DDOT( J-KI-1, T( KI+1, J+1 ), 1, + $ WORK( KI+1+IV*N ), 1 ) +* +* Solve +* [ T(J,J)-WR T(J,J+1) ]**T * 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+IV*N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+IV*N ), 1 ) + WORK( J +IV*N ) = X( 1, 1 ) + WORK( J+1+IV*N ) = X( 2, 1 ) +* + VMAX = MAX( ABS( WORK( J +IV*N ) ), + $ ABS( WORK( J+1+IV*N ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + END IF + 170 CONTINUE +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.OVER ) THEN +* ------------------------------ +* no back-transform: copy x to VL and normalize. + CALL DCOPY( N-KI+1, WORK( KI + IV*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( NB.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( KI.LT.N ) + $ CALL DGEMV( 'N', N, N-KI, ONE, + $ VL( 1, KI+1 ), LDVL, + $ WORK( KI+1 + IV*N ), 1, + $ WORK( KI + IV*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 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out above vector +* could go from KI-NV+1 to KI-1 + DO K = 1, KI - 1 + WORK( K + IV*N ) = ZERO + END DO + ISCOMPLEX( IV ) = IP +* back-transform and normalization is done below + END IF + ELSE +* +* -------------------------------------------------------- +* Complex left eigenvector. +* +* Initial solve: +* [ ( T(KI,KI) T(KI,KI+1) )**T - (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 + (IV )*N ) = WI / T( KI, KI+1 ) + WORK( KI+1 + (IV+1)*N ) = ONE + ELSE + WORK( KI + (IV )*N ) = ONE + WORK( KI+1 + (IV+1)*N ) = -WI / T( KI+1, KI ) + END IF + WORK( KI+1 + (IV )*N ) = ZERO + WORK( KI + (IV+1)*N ) = ZERO +* +* Form right-hand side. +* + DO 190 K = KI + 2, N + WORK( K+(IV )*N ) = -WORK( KI +(IV )*N )*T(KI, K) + WORK( K+(IV+1)*N ) = -WORK( KI+1+(IV+1)*N )*T(KI+1,K) + 190 CONTINUE +* +* Solve transposed quasi-triangular system: +* [ T(KI+2:N,KI+2:N)**T - (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+(IV )*N), 1 ) + CALL DSCAL( N-KI+1, REC, WORK(KI+(IV+1)*N), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+(IV )*N ) = WORK( J+(IV)*N ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+(IV)*N ), 1 ) + WORK( J+(IV+1)*N ) = WORK( J+(IV+1)*N ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+(IV+1)*N ), 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+IV*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+(IV )*N), 1) + CALL DSCAL( N-KI+1, SCALE, WORK(KI+(IV+1)*N), 1) + END IF + WORK( J+(IV )*N ) = X( 1, 1 ) + WORK( J+(IV+1)*N ) = X( 1, 2 ) + VMAX = MAX( ABS( WORK( J+(IV )*N ) ), + $ ABS( WORK( J+(IV+1)*N ) ), 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+(IV )*N), 1 ) + CALL DSCAL( N-KI+1, REC, WORK(KI+(IV+1)*N), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J +(IV )*N ) = WORK( J+(IV)*N ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+(IV)*N ), 1 ) +* + WORK( J +(IV+1)*N ) = WORK( J+(IV+1)*N ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+(IV+1)*N ), 1 ) +* + WORK( J+1+(IV )*N ) = WORK( J+1+(IV)*N ) - + $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, + $ WORK( KI+2+(IV)*N ), 1 ) +* + WORK( J+1+(IV+1)*N ) = WORK( J+1+(IV+1)*N ) - + $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, + $ WORK( KI+2+(IV+1)*N ), 1 ) +* +* Solve 2-by-2 complex linear equation +* [ (T(j,j) T(j,j+1) )**T - (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+IV*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+(IV )*N), 1) + CALL DSCAL( N-KI+1, SCALE, WORK(KI+(IV+1)*N), 1) + END IF + WORK( J +(IV )*N ) = X( 1, 1 ) + WORK( J +(IV+1)*N ) = X( 1, 2 ) + WORK( J+1+(IV )*N ) = X( 2, 1 ) + WORK( J+1+(IV+1)*N ) = 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 +* ------------------------------ +* no back-transform: copy x to VL and normalize. + CALL DCOPY( N-KI+1, WORK( KI + (IV )*N ), 1, + $ VL( KI, IS ), 1 ) + CALL DCOPY( N-KI+1, WORK( KI + (IV+1)*N ), 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( NB.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( KI.LT.N-1 ) THEN + CALL DGEMV( 'N', N, N-KI-1, ONE, + $ VL( 1, KI+2 ), LDVL, + $ WORK( KI+2 + (IV)*N ), 1, + $ WORK( KI + (IV)*N ), + $ VL( 1, KI ), 1 ) + CALL DGEMV( 'N', N, N-KI-1, ONE, + $ VL( 1, KI+2 ), LDVL, + $ WORK( KI+2 + (IV+1)*N ), 1, + $ WORK( KI+1 + (IV+1)*N ), + $ VL( 1, KI+1 ), 1 ) + ELSE + CALL DSCAL( N, WORK(KI+ (IV )*N), VL(1, KI ), 1) + CALL DSCAL( N, WORK(KI+1+(IV+1)*N), 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 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out above vector +* could go from KI-NV+1 to KI-1 + DO K = 1, KI - 1 + WORK( K + (IV )*N ) = ZERO + WORK( K + (IV+1)*N ) = ZERO + END DO + ISCOMPLEX( IV ) = IP + ISCOMPLEX( IV+1 ) = -IP + IV = IV + 1 +* back-transform and normalization is done below + END IF + END IF + + IF( NB.GT.1 ) THEN +* -------------------------------------------------------- +* Blocked version of back-transform +* For complex case, KI2 includes both vectors (KI and KI+1) + IF( IP.EQ.0 ) THEN + KI2 = KI + ELSE + KI2 = KI + 1 + END IF + +* Columns 1:IV of work are valid vectors. +* When the number of vectors stored reaches NB-1 or NB, +* or if this was last vector, do the GEMM + IF( (IV.GE.NB-1) .OR. (KI2.EQ.N) ) THEN + CALL DGEMM( 'N', 'N', N, IV, N-KI2+IV, ONE, + $ VL( 1, KI2-IV+1 ), LDVL, + $ WORK( KI2-IV+1 + (1)*N ), N, + $ ZERO, + $ WORK( 1 + (NB+1)*N ), N ) +* normalize vectors + DO K = 1, IV + IF( ISCOMPLEX(K).EQ.0) THEN +* real eigenvector + II = IDAMAX( N, WORK( 1 + (NB+K)*N ), 1 ) + REMAX = ONE / ABS( WORK( II + (NB+K)*N ) ) + ELSE IF( ISCOMPLEX(K).EQ.1) THEN +* first eigenvector of conjugate pair + EMAX = ZERO + DO II = 1, N + EMAX = MAX( EMAX, + $ ABS( WORK( II + (NB+K )*N ) )+ + $ ABS( WORK( II + (NB+K+1)*N ) ) ) + END DO + REMAX = ONE / EMAX +* else if ISCOMPLEX(K).EQ.-1 +* second eigenvector of conjugate pair +* reuse same REMAX as previous K + END IF + CALL DSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 ) + END DO + CALL DLACPY( 'F', N, IV, + $ WORK( 1 + (NB+1)*N ), N, + $ VL( 1, KI2-IV+1 ), LDVL ) + IV = 1 + ELSE + IV = IV + 1 + END IF + END IF ! blocked back-transform +* + IS = IS + 1 + IF( IP.NE.0 ) + $ IS = IS + 1 + 260 CONTINUE + END IF +* + RETURN +* +* End of DTREVC3 +* + END diff --git a/math/lapack/src/main/fortran/dtrexc.f b/math/lapack/src/main/fortran/dtrexc.f new file mode 100644 index 0000000000..468ae47b95 --- /dev/null +++ b/math/lapack/src/main/fortran/dtrexc.f @@ -0,0 +1,428 @@ +*> \brief \b DTREXC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTREXC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER COMPQ +* INTEGER IFST, ILST, INFO, LDQ, LDT, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] COMPQ +*> \verbatim +*> COMPQ is CHARACTER*1 +*> = 'V': update the matrix Q of Schur vectors; +*> = 'N': do not update Q. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. N >= 0. +*> If N == 0 arguments ILST and IFST may be any value. +*> \endverbatim +*> +*> \param[in,out] T +*> \verbatim +*> T is 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. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is 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. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= 1, and if +*> COMPQ = 'V', LDQ >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] IFST +*> \verbatim +*> IFST is INTEGER +*> \endverbatim +*> +*> \param[in,out] ILST +*> \verbatim +*> ILST is 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. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> = 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER COMPQ + INTEGER IFST, ILST, INFO, LDQ, LDT, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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 ).AND.( N.GT.0 )) THEN + INFO = -7 + ELSE IF(( ILST.LT.1 .OR. ILST.GT.N ).AND.( N.GT.0 )) 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/math/lapack/src/main/fortran/dtrrfs.f b/math/lapack/src/main/fortran/dtrrfs.f new file mode 100644 index 0000000000..c9fe55c721 --- /dev/null +++ b/math/lapack/src/main/fortran/dtrrfs.f @@ -0,0 +1,472 @@ +*> \brief \b DTRRFS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTRRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, +* LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, TRANS, UPLO +* INTEGER INFO, LDA, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ), +* $ WORK( * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTRRFS provides error bounds and backward error estimates for the +*> solution to a system of linear equations with a triangular +*> coefficient matrix. +*> +*> The solution matrix X must be computed by DTRTRS or some other +*> means before entering this routine. DTRRFS does not do iterative +*> refinement because doing so cannot improve the backward error. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> = 'N': A is non-unit triangular; +*> = 'U': A is unit triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> The right hand side matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> The solution matrix X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[out] FERR +*> \verbatim +*> FERR is 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. +*> \endverbatim +*> +*> \param[out] BERR +*> \verbatim +*> BERR is 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). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, + $ LDX, FERR, BERR, WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, TRANS, UPLO + INTEGER INFO, LDA, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ), + $ WORK( * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN, NOUNIT, UPPER + CHARACTER TRANST + INTEGER I, J, K, KASE, NZ + DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLACN2, DTRMV, DTRSV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + NOTRAN = LSAME( TRANS, 'N' ) + NOUNIT = LSAME( DIAG, 'N' ) +* + 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( 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 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTRRFS', -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 250 J = 1, NRHS +* +* Compute residual R = B - op(A) * X, +* where op(A) = A or A**T, depending on TRANS. +* + CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 ) + CALL DTRMV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ), 1 ) + CALL DAXPY( N, -ONE, B( 1, J ), 1, 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 20 I = 1, N + WORK( I ) = ABS( B( I, J ) ) + 20 CONTINUE +* + IF( NOTRAN ) THEN +* +* Compute abs(A)*abs(X) + abs(B). +* + IF( UPPER ) THEN + IF( NOUNIT ) THEN + DO 40 K = 1, N + XK = ABS( X( K, J ) ) + DO 30 I = 1, K + WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK + 30 CONTINUE + 40 CONTINUE + ELSE + DO 60 K = 1, N + XK = ABS( X( K, J ) ) + DO 50 I = 1, K - 1 + WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK + 50 CONTINUE + WORK( K ) = WORK( K ) + XK + 60 CONTINUE + END IF + ELSE + IF( NOUNIT ) THEN + DO 80 K = 1, N + XK = ABS( X( K, J ) ) + DO 70 I = K, N + WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK + 70 CONTINUE + 80 CONTINUE + ELSE + DO 100 K = 1, N + XK = ABS( X( K, J ) ) + DO 90 I = K + 1, N + WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK + 90 CONTINUE + WORK( K ) = WORK( K ) + XK + 100 CONTINUE + END IF + END IF + ELSE +* +* Compute abs(A**T)*abs(X) + abs(B). +* + IF( UPPER ) THEN + IF( NOUNIT ) THEN + DO 120 K = 1, N + S = ZERO + DO 110 I = 1, K + S = S + ABS( A( I, K ) )*ABS( X( I, J ) ) + 110 CONTINUE + WORK( K ) = WORK( K ) + S + 120 CONTINUE + ELSE + DO 140 K = 1, N + S = ABS( X( K, J ) ) + DO 130 I = 1, K - 1 + S = S + ABS( A( I, K ) )*ABS( X( I, J ) ) + 130 CONTINUE + WORK( K ) = WORK( K ) + S + 140 CONTINUE + END IF + ELSE + IF( NOUNIT ) THEN + DO 160 K = 1, N + S = ZERO + DO 150 I = K, N + S = S + ABS( A( I, K ) )*ABS( X( I, J ) ) + 150 CONTINUE + WORK( K ) = WORK( K ) + S + 160 CONTINUE + ELSE + DO 180 K = 1, N + S = ABS( X( K, J ) ) + DO 170 I = K + 1, N + S = S + ABS( A( I, K ) )*ABS( X( I, J ) ) + 170 CONTINUE + WORK( K ) = WORK( K ) + S + 180 CONTINUE + END IF + END IF + END IF + S = ZERO + DO 190 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 + 190 CONTINUE + BERR( J ) = S +* +* Bound error from formula +* +* norm(X - XTRUE) / norm(X) .le. FERR = +* norm( abs(inv(op(A)))* +* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) +* +* where +* norm(Z) is the magnitude of the largest component of Z +* inv(op(A)) is the inverse of op(A) +* abs(Z) is the componentwise absolute value of the matrix or +* vector Z +* NZ is the maximum number of nonzeros in any row of A, plus 1 +* EPS is machine epsilon +* +* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) +* is incremented by SAFE1 if the i-th component of +* abs(op(A))*abs(X) + abs(B) is less than SAFE2. +* +* Use DLACN2 to estimate the infinity-norm of the matrix +* inv(op(A)) * diag(W), +* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) +* + DO 200 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 + 200 CONTINUE +* + KASE = 0 + 210 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 DTRSV( UPLO, TRANST, DIAG, N, A, LDA, WORK( N+1 ), + $ 1 ) + DO 220 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 220 CONTINUE + ELSE +* +* Multiply by inv(op(A))*diag(W). +* + DO 230 I = 1, N + WORK( N+I ) = WORK( I )*WORK( N+I ) + 230 CONTINUE + CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ), + $ 1 ) + END IF + GO TO 210 + END IF +* +* Normalize error. +* + LSTRES = ZERO + DO 240 I = 1, N + LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) + 240 CONTINUE + IF( LSTRES.NE.ZERO ) + $ FERR( J ) = FERR( J ) / LSTRES +* + 250 CONTINUE +* + RETURN +* +* End of DTRRFS +* + END diff --git a/math/lapack/src/main/fortran/dtrsen.f b/math/lapack/src/main/fortran/dtrsen.f new file mode 100644 index 0000000000..1fa126c5be --- /dev/null +++ b/math/lapack/src/main/fortran/dtrsen.f @@ -0,0 +1,570 @@ +*> \brief \b DTRSEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTRSEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, +* M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) +* +* .. 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( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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 elements equal and its +*> off-diagonal elements of opposite sign. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is 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). +*> \endverbatim +*> +*> \param[in] COMPQ +*> \verbatim +*> COMPQ is CHARACTER*1 +*> = 'V': update the matrix Q of Schur vectors; +*> = 'N': do not update Q. +*> \endverbatim +*> +*> \param[in] SELECT +*> \verbatim +*> SELECT is 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. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in,out] T +*> \verbatim +*> T is 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. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is 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. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. +*> LDQ >= 1; and if COMPQ = 'V', LDQ >= N. +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> \param[out] WI +*> \verbatim +*> WI is 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. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The dimension of the specified invariant subspace. +*> 0 < = M <= N. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is 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. +*> \endverbatim +*> +*> \param[out] SEP +*> \verbatim +*> SEP is 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. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> 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. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 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 * T * Z = ( T11 T12 ) n1 +*> ( 0 T22 ) n2 +*> n1 n2 +*> +*> where N = n1+n2 and Z**T 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**T, then the reordered real Schur factorization of A is given +*> by A = (Q*Z)*(Z**T*T*Z)*(Q*Z)**T, 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 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, + $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. 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( * ) +* .. +* +* ===================================================================== +* +* .. 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**T*R - R*T22**T = 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/math/lapack/src/main/fortran/dtrsna.f b/math/lapack/src/main/fortran/dtrsna.f new file mode 100644 index 0000000000..2966e5fb5a --- /dev/null +++ b/math/lapack/src/main/fortran/dtrsna.f @@ -0,0 +1,603 @@ +*> \brief \b DTRSNA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTRSNA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, +* LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER HOWMNY, JOB +* INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N +* .. +* .. Array Arguments .. +* LOGICAL SELECT( * ) +* INTEGER IWORK( * ) +* DOUBLE PRECISION S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ), +* $ VR( LDVR, * ), WORK( LDWORK, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTRSNA estimates reciprocal condition numbers for specified +*> eigenvalues and/or right eigenvectors of a real upper +*> quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q +*> orthogonal). +*> +*> T must be in Schur canonical form (as returned by DHSEQR), that is, +*> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each +*> 2-by-2 diagonal block has its diagonal elements equal and its +*> off-diagonal elements of opposite sign. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is CHARACTER*1 +*> Specifies whether condition numbers are required for +*> eigenvalues (S) or eigenvectors (SEP): +*> = 'E': for eigenvalues only (S); +*> = 'V': for eigenvectors only (SEP); +*> = 'B': for both eigenvalues and eigenvectors (S and SEP). +*> \endverbatim +*> +*> \param[in] HOWMNY +*> \verbatim +*> HOWMNY is CHARACTER*1 +*> = 'A': compute condition numbers for all eigenpairs; +*> = 'S': compute condition numbers for selected eigenpairs +*> specified by the array SELECT. +*> \endverbatim +*> +*> \param[in] SELECT +*> \verbatim +*> SELECT is LOGICAL array, dimension (N) +*> If HOWMNY = 'S', SELECT specifies the eigenpairs for which +*> condition numbers are required. To select condition numbers +*> for the eigenpair corresponding to a real eigenvalue w(j), +*> SELECT(j) must be set to .TRUE.. To select condition numbers +*> corresponding to a complex conjugate pair of eigenvalues w(j) +*> and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be +*> set to .TRUE.. +*> If HOWMNY = 'A', SELECT is not referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> The upper quasi-triangular matrix T, in Schur canonical form. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION array, dimension (LDVL,M) +*> If JOB = 'E' or 'B', VL must contain left eigenvectors of T +*> (or of any Q*T*Q**T with Q orthogonal), corresponding to the +*> eigenpairs specified by HOWMNY and SELECT. The eigenvectors +*> must be stored in consecutive columns of VL, as returned by +*> DHSEIN or DTREVC. +*> If JOB = 'V', VL is not referenced. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the array VL. +*> LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. +*> \endverbatim +*> +*> \param[in] VR +*> \verbatim +*> VR is DOUBLE PRECISION array, dimension (LDVR,M) +*> If JOB = 'E' or 'B', VR must contain right eigenvectors of T +*> (or of any Q*T*Q**T with Q orthogonal), corresponding to the +*> eigenpairs specified by HOWMNY and SELECT. The eigenvectors +*> must be stored in consecutive columns of VR, as returned by +*> DHSEIN or DTREVC. +*> If JOB = 'V', VR is not referenced. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. +*> LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (MM) +*> If JOB = 'E' or 'B', the reciprocal condition numbers of the +*> selected eigenvalues, stored in consecutive elements of the +*> array. For a complex conjugate pair of eigenvalues two +*> consecutive elements of S are set to the same value. Thus +*> S(j), SEP(j), and the j-th columns of VL and VR all +*> correspond to the same eigenpair (but not in general the +*> j-th eigenpair, unless all eigenpairs are selected). +*> If JOB = 'V', S is not referenced. +*> \endverbatim +*> +*> \param[out] SEP +*> \verbatim +*> SEP is DOUBLE PRECISION array, dimension (MM) +*> If JOB = 'V' or 'B', the estimated reciprocal condition +*> numbers of the selected eigenvectors, stored in consecutive +*> elements of the array. For a complex eigenvector two +*> consecutive elements of SEP are set to the same value. If +*> the eigenvalues cannot be reordered to compute SEP(j), SEP(j) +*> is set to 0; this can only occur when the true value would be +*> very small anyway. +*> If JOB = 'E', SEP is not referenced. +*> \endverbatim +*> +*> \param[in] MM +*> \verbatim +*> MM is INTEGER +*> The number of elements in the arrays S (if JOB = 'E' or 'B') +*> and/or SEP (if JOB = 'V' or 'B'). MM >= M. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The number of elements of the arrays S and/or SEP actually +*> used to store the estimated condition numbers. +*> If HOWMNY = 'A', M is set to N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LDWORK,N+6) +*> If JOB = 'E', WORK is not referenced. +*> \endverbatim +*> +*> \param[in] LDWORK +*> \verbatim +*> LDWORK is INTEGER +*> The leading dimension of the array WORK. +*> LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*(N-1)) +*> If JOB = 'E', IWORK is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The reciprocal of the condition number of an eigenvalue lambda is +*> defined as +*> +*> S(lambda) = |v**T*u| / (norm(u)*norm(v)) +*> +*> where u and v are the right and left eigenvectors of T corresponding +*> to lambda; v**T denotes the transpose of v, and norm(u) +*> denotes the Euclidean norm. These reciprocal condition numbers always +*> lie between zero (very badly conditioned) and one (very well +*> conditioned). If n = 1, S(lambda) is defined to be 1. +*> +*> An approximate error bound for a computed eigenvalue W(i) is given by +*> +*> EPS * norm(T) / S(i) +*> +*> where EPS is the machine precision. +*> +*> The reciprocal of the condition number of the right eigenvector u +*> corresponding to lambda is defined as follows. Suppose +*> +*> T = ( lambda c ) +*> ( 0 T22 ) +*> +*> Then the reciprocal condition number is +*> +*> SEP( lambda, T22 ) = sigma-min( T22 - lambda*I ) +*> +*> where sigma-min denotes the smallest singular value. We approximate +*> the smallest singular value by the reciprocal of an estimate of the +*> one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is +*> defined to be abs(T(1,1)). +*> +*> An approximate error bound for a computed right eigenvector VR(i) +*> is given by +*> +*> EPS * norm(T) / SEP(i) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + $ LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER HOWMNY, JOB + INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ), + $ VR( LDVR, * ), WORK( LDWORK, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL PAIR, SOMCON, WANTBH, WANTS, WANTSP + INTEGER I, IERR, IFST, ILST, J, K, KASE, KS, N2, NN + DOUBLE PRECISION BIGNUM, COND, CS, DELTA, DUMM, EPS, EST, LNRM, + $ MU, PROD, PROD1, PROD2, RNRM, SCALE, SMLNUM, SN +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) + DOUBLE PRECISION DUMMY( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT, DLAMCH, DLAPY2, DNRM2 + EXTERNAL LSAME, DDOT, DLAMCH, DLAPY2, DNRM2 +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DLACPY, DLAQTR, DTREXC, 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 +* + SOMCON = LSAME( HOWMNY, 'S' ) +* + INFO = 0 + IF( .NOT.WANTS .AND. .NOT.WANTSP ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) 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. ( WANTS .AND. LDVL.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDVR.LT.1 .OR. ( WANTS .AND. LDVR.LT.N ) ) THEN + INFO = -10 + ELSE +* +* Set M to the number of eigenpairs for which condition numbers +* are required, and test MM. +* + IF( SOMCON ) THEN + 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 + ELSE + M = N + END IF +* + IF( MM.LT.M ) THEN + INFO = -13 + ELSE IF( LDWORK.LT.1 .OR. ( WANTSP .AND. LDWORK.LT.N ) ) THEN + INFO = -16 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTRSNA', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( SOMCON ) THEN + IF( .NOT.SELECT( 1 ) ) + $ RETURN + END IF + IF( WANTS ) + $ S( 1 ) = ONE + IF( WANTSP ) + $ SEP( 1 ) = ABS( T( 1, 1 ) ) + RETURN + END IF +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* + KS = 0 + PAIR = .FALSE. + DO 60 K = 1, N +* +* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block. +* + IF( PAIR ) THEN + PAIR = .FALSE. + GO TO 60 + ELSE + IF( K.LT.N ) + $ PAIR = T( K+1, K ).NE.ZERO + END IF +* +* Determine whether condition numbers are required for the k-th +* eigenpair. +* + IF( SOMCON ) THEN + IF( PAIR ) THEN + IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) ) + $ GO TO 60 + ELSE + IF( .NOT.SELECT( K ) ) + $ GO TO 60 + END IF + END IF +* + KS = KS + 1 +* + IF( WANTS ) THEN +* +* Compute the reciprocal condition number of the k-th +* eigenvalue. +* + IF( .NOT.PAIR ) THEN +* +* Real eigenvalue. +* + PROD = DDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 ) + RNRM = DNRM2( N, VR( 1, KS ), 1 ) + LNRM = DNRM2( N, VL( 1, KS ), 1 ) + S( KS ) = ABS( PROD ) / ( RNRM*LNRM ) + ELSE +* +* Complex eigenvalue. +* + PROD1 = DDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 ) + PROD1 = PROD1 + DDOT( N, VR( 1, KS+1 ), 1, VL( 1, KS+1 ), + $ 1 ) + PROD2 = DDOT( N, VL( 1, KS ), 1, VR( 1, KS+1 ), 1 ) + PROD2 = PROD2 - DDOT( N, VL( 1, KS+1 ), 1, VR( 1, KS ), + $ 1 ) + RNRM = DLAPY2( DNRM2( N, VR( 1, KS ), 1 ), + $ DNRM2( N, VR( 1, KS+1 ), 1 ) ) + LNRM = DLAPY2( DNRM2( N, VL( 1, KS ), 1 ), + $ DNRM2( N, VL( 1, KS+1 ), 1 ) ) + COND = DLAPY2( PROD1, PROD2 ) / ( RNRM*LNRM ) + S( KS ) = COND + S( KS+1 ) = COND + END IF + END IF +* + IF( WANTSP ) THEN +* +* Estimate the reciprocal condition number of the k-th +* eigenvector. +* +* Copy the matrix T to the array WORK and swap the diagonal +* block beginning at T(k,k) to the (1,1) position. +* + CALL DLACPY( 'Full', N, N, T, LDT, WORK, LDWORK ) + IFST = K + ILST = 1 + CALL DTREXC( 'No Q', N, WORK, LDWORK, DUMMY, 1, IFST, ILST, + $ WORK( 1, N+1 ), IERR ) +* + IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN +* +* Could not swap because blocks not well separated +* + SCALE = ONE + EST = BIGNUM + ELSE +* +* Reordering successful +* + IF( WORK( 2, 1 ).EQ.ZERO ) THEN +* +* Form C = T22 - lambda*I in WORK(2:N,2:N). +* + DO 20 I = 2, N + WORK( I, I ) = WORK( I, I ) - WORK( 1, 1 ) + 20 CONTINUE + N2 = 1 + NN = N - 1 + ELSE +* +* Triangularize the 2 by 2 block by unitary +* transformation U = [ cs i*ss ] +* [ i*ss cs ]. +* such that the (1,1) position of WORK is complex +* eigenvalue lambda with positive imaginary part. (2,2) +* position of WORK is the complex eigenvalue lambda +* with negative imaginary part. +* + MU = SQRT( ABS( WORK( 1, 2 ) ) )* + $ SQRT( ABS( WORK( 2, 1 ) ) ) + DELTA = DLAPY2( MU, WORK( 2, 1 ) ) + CS = MU / DELTA + SN = -WORK( 2, 1 ) / DELTA +* +* Form +* +* C**T = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ] +* [ mu ] +* [ .. ] +* [ .. ] +* [ mu ] +* where C**T is transpose of matrix C, +* and RWORK is stored starting in the N+1-st column of +* WORK. +* + DO 30 J = 3, N + WORK( 2, J ) = CS*WORK( 2, J ) + WORK( J, J ) = WORK( J, J ) - WORK( 1, 1 ) + 30 CONTINUE + WORK( 2, 2 ) = ZERO +* + WORK( 1, N+1 ) = TWO*MU + DO 40 I = 2, N - 1 + WORK( I, N+1 ) = SN*WORK( 1, I+1 ) + 40 CONTINUE + N2 = 2 + NN = 2*( N-1 ) + END IF +* +* Estimate norm(inv(C**T)) +* + EST = ZERO + KASE = 0 + 50 CONTINUE + CALL DLACN2( NN, WORK( 1, N+2 ), WORK( 1, N+4 ), IWORK, + $ EST, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN + IF( N2.EQ.1 ) THEN +* +* Real eigenvalue: solve C**T*x = scale*c. +* + CALL DLAQTR( .TRUE., .TRUE., N-1, WORK( 2, 2 ), + $ LDWORK, DUMMY, DUMM, SCALE, + $ WORK( 1, N+4 ), WORK( 1, N+6 ), + $ IERR ) + ELSE +* +* Complex eigenvalue: solve +* C**T*(p+iq) = scale*(c+id) in real arithmetic. +* + CALL DLAQTR( .TRUE., .FALSE., N-1, WORK( 2, 2 ), + $ LDWORK, WORK( 1, N+1 ), MU, SCALE, + $ WORK( 1, N+4 ), WORK( 1, N+6 ), + $ IERR ) + END IF + ELSE + IF( N2.EQ.1 ) THEN +* +* Real eigenvalue: solve C*x = scale*c. +* + CALL DLAQTR( .FALSE., .TRUE., N-1, WORK( 2, 2 ), + $ LDWORK, DUMMY, DUMM, SCALE, + $ WORK( 1, N+4 ), WORK( 1, N+6 ), + $ IERR ) + ELSE +* +* Complex eigenvalue: solve +* C*(p+iq) = scale*(c+id) in real arithmetic. +* + CALL DLAQTR( .FALSE., .FALSE., N-1, + $ WORK( 2, 2 ), LDWORK, + $ WORK( 1, N+1 ), MU, SCALE, + $ WORK( 1, N+4 ), WORK( 1, N+6 ), + $ IERR ) +* + END IF + END IF +* + GO TO 50 + END IF + END IF +* + SEP( KS ) = SCALE / MAX( EST, SMLNUM ) + IF( PAIR ) + $ SEP( KS+1 ) = SEP( KS ) + END IF +* + IF( PAIR ) + $ KS = KS + 1 +* + 60 CONTINUE + RETURN +* +* End of DTRSNA +* + END diff --git a/math/lapack/src/main/fortran/dtrsyl.f b/math/lapack/src/main/fortran/dtrsyl.f new file mode 100644 index 0000000000..105032cb33 --- /dev/null +++ b/math/lapack/src/main/fortran/dtrsyl.f @@ -0,0 +1,1002 @@ +*> \brief \b DTRSYL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTRSYL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, +* LDC, SCALE, INFO ) +* +* .. 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, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANA +*> \verbatim +*> TRANA is 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) +*> \endverbatim +*> +*> \param[in] TRANB +*> \verbatim +*> TRANB is 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) +*> \endverbatim +*> +*> \param[in] ISGN +*> \verbatim +*> ISGN is 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 +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The order of the matrix A, and the number of rows in the +*> matrices X and C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix B, and the number of columns in the +*> matrices X and C. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,M) +*> The upper quasi-triangular matrix A, in Schur canonical form. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> The upper quasi-triangular matrix B, in Schur canonical form. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is 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. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M) +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION +*> The scale factor, scale, set <= 1 to avoid overflow in X. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is 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). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, + $ LDC, SCALE, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. 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, * ) +* .. +* +* ===================================================================== +* +* .. 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 +* + SCALE = ONE + 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 ) ) +* + 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**T *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)**T*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) +* +* Where +* K-1 T L-1 +* R(K,L) = SUM [A(I,K)**T*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**T*X + ISGN*X*B**T = scale*C. +* +* The (K,L)th block of X is determined starting from +* top-right corner column by column by +* +* A(K,K)**T*X(K,L) + ISGN*X(K,L)*B(L,L)**T = C(K,L) - R(K,L) +* +* Where +* K-1 N +* R(K,L) = SUM [A(I,K)**T*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)**T]. +* 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**T = 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)**T = 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)**T]. +* 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/math/lapack/src/main/fortran/dtrti2.f b/math/lapack/src/main/fortran/dtrti2.f new file mode 100644 index 0000000000..0a9d5b696c --- /dev/null +++ b/math/lapack/src/main/fortran/dtrti2.f @@ -0,0 +1,212 @@ +*> \brief \b DTRTI2 computes the inverse of a triangular matrix (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTRTI2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTRTI2 computes the inverse of a real upper or lower triangular +*> matrix. +*> +*> This is the Level 2 BLAS version of the algorithm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the matrix A is upper or lower triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the matrix A is unit triangular. +*> = 'N': Non-unit triangular +*> = 'U': Unit triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dtrtri.f b/math/lapack/src/main/fortran/dtrtri.f new file mode 100644 index 0000000000..d34b40bcc0 --- /dev/null +++ b/math/lapack/src/main/fortran/dtrtri.f @@ -0,0 +1,242 @@ +*> \brief \b DTRTRI +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTRTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTRTRI computes the inverse of a real upper or lower triangular +*> matrix A. +*> +*> This is the Level 3 BLAS version of the algorithm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> = 'N': A is non-unit triangular; +*> = 'U': A is unit triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, A(i,i) is exactly zero. The triangular +*> matrix is singular and its inverse can not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/dtrtrs.f b/math/lapack/src/main/fortran/dtrtrs.f new file mode 100644 index 0000000000..3e5ff6fda1 --- /dev/null +++ b/math/lapack/src/main/fortran/dtrtrs.f @@ -0,0 +1,226 @@ +*> \brief \b DTRTRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTRTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, TRANS, UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is 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) +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> = 'N': A is non-unit triangular; +*> = 'U': A is unit triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, if INFO = 0, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG, TRANS, UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. 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**T * x = b. +* + CALL DTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B, + $ LDB ) +* + RETURN +* +* End of DTRTRS +* + END diff --git a/math/lapack/src/main/fortran/dtrttf.f b/math/lapack/src/main/fortran/dtrttf.f new file mode 100644 index 0000000000..8e91c3df81 --- /dev/null +++ b/math/lapack/src/main/fortran/dtrttf.f @@ -0,0 +1,492 @@ +*> \brief \b DTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed format (TF). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTRTTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANSR, UPLO +* INTEGER INFO, N, LDA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( 0: LDA-1, 0: * ), ARF( 0: * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTRTTF copies a triangular matrix A from standard full format (TR) +*> to rectangular full packed format (TF) . +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSR +*> \verbatim +*> TRANSR is CHARACTER*1 +*> = 'N': ARF in Normal form is wanted; +*> = 'T': ARF in Transpose form is wanted. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the matrix A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] ARF +*> \verbatim +*> ARF is DOUBLE PRECISION array, dimension (NT). +*> NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> We first consider Rectangular Full Packed (RFP) Format when N is +*> even. We give an example where N = 6. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 05 00 +*> 11 12 13 14 15 10 11 +*> 22 23 24 25 20 21 22 +*> 33 34 35 30 31 32 33 +*> 44 45 40 41 42 43 44 +*> 55 50 51 52 53 54 55 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(4:6,0:2) consists of +*> the transpose of the first three columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:2,0:2) consists of +*> the transpose of the last three columns of AP lower. +*> This covers the case N even and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 03 04 05 33 43 53 +*> 13 14 15 00 44 54 +*> 23 24 25 10 11 55 +*> 33 34 35 20 21 22 +*> 00 44 45 30 31 32 +*> 01 11 55 40 41 42 +*> 02 12 22 50 51 52 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> +*> RFP A RFP A +*> +*> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +*> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +*> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +*> +*> +*> We then consider Rectangular Full Packed (RFP) Format when N is +*> odd. We give an example where N = 5. +*> +*> AP is Upper AP is Lower +*> +*> 00 01 02 03 04 00 +*> 11 12 13 14 10 11 +*> 22 23 24 20 21 22 +*> 33 34 30 31 32 33 +*> 44 40 41 42 43 44 +*> +*> +*> Let TRANSR = 'N'. RFP holds AP as follows: +*> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +*> three columns of AP upper. The lower triangle A(3:4,0:1) consists of +*> the transpose of the first two columns of AP upper. +*> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +*> three columns of AP lower. The upper triangle A(0:1,1:2) consists of +*> the transpose of the last two columns of AP lower. +*> This covers the case N odd and TRANSR = 'N'. +*> +*> RFP A RFP A +*> +*> 02 03 04 00 33 43 +*> 12 13 14 10 11 44 +*> 22 23 24 20 21 22 +*> 00 33 34 30 31 32 +*> 01 11 44 40 41 42 +*> +*> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +*> transpose of RFP A above. One therefore gets: +*> +*> RFP A RFP A +*> +*> 02 12 22 00 01 00 10 20 30 40 50 +*> 03 13 23 33 11 33 11 21 31 41 51 +*> 04 14 24 34 44 43 44 22 32 42 52 +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( 0: LDA-1, 0: * ), ARF( 0: * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTRTTF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) THEN + IF( N.EQ.1 ) THEN + ARF( 0 ) = A( 0, 0 ) + END IF + RETURN + END IF +* +* Size of array ARF(0:nt-1) +* + NT = N*( N+1 ) / 2 +* +* Set N1 and N2 depending on LOWER: for N even N1=N2=K +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. +* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is +* N--by--(N+1)/2. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + IF( .NOT.LOWER ) + $ NP1X2 = N + N + 2 + ELSE + NISODD = .TRUE. + IF( .NOT.LOWER ) + $ NX2 = N + N + END IF +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'N', and UPLO = 'L' +* + IJ = 0 + DO J = 0, N2 + DO I = N1, N2 + J + ARF( IJ ) = A( N2+J, I ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is odd, TRANSR = 'N', and UPLO = 'U' +* + IJ = NT - N + DO J = N - 1, N1, -1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = J - N1, N1 - 1 + ARF( IJ ) = A( J-N1, L ) + IJ = IJ + 1 + END DO + IJ = IJ - NX2 + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'T', and UPLO = 'L' +* + IJ = 0 + DO J = 0, N2 - 1 + DO I = 0, J + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + DO I = N1 + J, N - 1 + ARF( IJ ) = A( I, N1+J ) + IJ = IJ + 1 + END DO + END DO + DO J = N2, N - 1 + DO I = 0, N1 - 1 + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is odd, TRANSR = 'T', and UPLO = 'U' +* + IJ = 0 + DO J = 0, N1 + DO I = N1, N - 1 + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, N1 - 1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = N2 + J, N - 1 + ARF( IJ ) = A( N2+J, L ) + IJ = IJ + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'N', and UPLO = 'L' +* + IJ = 0 + DO J = 0, K - 1 + DO I = K, K + J + ARF( IJ ) = A( K+J, I ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is even, TRANSR = 'N', and UPLO = 'U' +* + IJ = NT - N - 1 + DO J = N - 1, K, -1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = J - K, K - 1 + ARF( IJ ) = A( J-K, L ) + IJ = IJ + 1 + END DO + IJ = IJ - NP1X2 + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'T', and UPLO = 'L' +* + IJ = 0 + J = K + DO I = K, N - 1 + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO J = 0, K - 2 + DO I = 0, J + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + DO I = K + 1 + J, N - 1 + ARF( IJ ) = A( I, K+1+J ) + IJ = IJ + 1 + END DO + END DO + DO J = K - 1, N - 1 + DO I = 0, K - 1 + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is even, TRANSR = 'T', and UPLO = 'U' +* + IJ = 0 + DO J = 0, K + DO I = K, N - 1 + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, K - 2 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = K + 1 + J, N - 1 + ARF( IJ ) = A( K+1+J, L ) + IJ = IJ + 1 + END DO + END DO +* Note that here, on exit of the loop, J = K-1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of DTRTTF +* + END diff --git a/math/lapack/src/main/fortran/dtrttp.f b/math/lapack/src/main/fortran/dtrttp.f new file mode 100644 index 0000000000..ac10ef4beb --- /dev/null +++ b/math/lapack/src/main/fortran/dtrttp.f @@ -0,0 +1,176 @@ +*> \brief \b DTRTTP copies a triangular matrix from the standard full format (TR) to the standard packed format (TP). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTRTTP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTRTTP( UPLO, N, A, LDA, AP, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, N, LDA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), AP( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTRTTP copies a triangular matrix A from full format (TR) to standard +*> packed format (TP). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular. +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices AP and A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On exit, the triangular matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2 +*> On exit, the upper or lower triangular matrix A, packed +*> columnwise in a linear array. The j-th column of A is stored +*> in the array AP as follows: +*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DTRTTP( UPLO, N, A, LDA, AP, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), AP( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER + INTEGER I, J, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTRTTP', -INFO ) + RETURN + END IF +* + IF( LOWER ) THEN + K = 0 + DO J = 1, N + DO I = J, N + K = K + 1 + AP( K ) = A( I, J ) + END DO + END DO + ELSE + K = 0 + DO J = 1, N + DO I = 1, J + K = K + 1 + AP( K ) = A( I, J ) + END DO + END DO + END IF +* +* + RETURN +* +* End of DTRTTP +* + END diff --git a/math/lapack/src/main/fortran/dtzrzf.f b/math/lapack/src/main/fortran/dtzrzf.f new file mode 100644 index 0000000000..0d4f922c89 --- /dev/null +++ b/math/lapack/src/main/fortran/dtzrzf.f @@ -0,0 +1,313 @@ +*> \brief \b DTZRZF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTZRZF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= M. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is 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. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (M) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 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. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The N-by-N matrix Z can be computed by +*> +*> Z = Z(1)*Z(2)* ... *Z(M) +*> +*> where each N-by-N Z(k) is given by +*> +*> Z(k) = I - tau(k)*v(k)*v(k)**T +*> +*> with v(k) is the kth row vector of the M-by-N matrix +*> +*> V = ( I A(:,M+1:N) ) +*> +*> I is the M-by-M identity matrix, A(:,M+1:N) +*> is the output stored in A on exit from DTZRZF, +*> and tau(k) is the kth element of the array TAU. +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IWS, KI, KK, LDWORK, LWKMIN, LWKOPT, + $ M1, MU, NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLARZB, DLARZT, DLATRZ +* .. +* .. 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 + LWKMIN = 1 + ELSE +* +* Determine the block size. +* + NB = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 ) + LWKOPT = M*NB + LWKMIN = MAX( 1, M ) + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.LWKMIN .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/math/lapack/src/main/fortran/dzsum1.f b/math/lapack/src/main/fortran/dzsum1.f new file mode 100644 index 0000000000..70a404283e --- /dev/null +++ b/math/lapack/src/main/fortran/dzsum1.f @@ -0,0 +1,140 @@ +*> \brief \b DZSUM1 forms the 1-norm of the complex vector using the true absolute value. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DZSUM1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX ) +* +* .. Scalar Arguments .. +* INTEGER INCX, N +* .. +* .. Array Arguments .. +* COMPLEX*16 CX( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of elements in the vector CX. +*> \endverbatim +*> +*> \param[in] CX +*> \verbatim +*> CX is COMPLEX*16 array, dimension (N) +*> The vector whose elements will be summed. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The spacing between successive values of CX. INCX > 0. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Nick Higham for use with ZLACON. +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCX, N +* .. +* .. Array Arguments .. + COMPLEX*16 CX( * ) +* .. +* +* ===================================================================== +* +* .. 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/math/lapack/src/main/fortran/icmax1.f b/math/lapack/src/main/fortran/icmax1.f new file mode 100644 index 0000000000..4141473878 --- /dev/null +++ b/math/lapack/src/main/fortran/icmax1.f @@ -0,0 +1,141 @@ +*> \brief \b ICMAX1 finds the index of the first vector element of maximum absolute value. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ICMAX1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ICMAX1( N, CX, INCX ) +* +* .. Scalar Arguments .. +* INTEGER INCX, N +* .. +* .. Array Arguments .. +* COMPLEX CX( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ICMAX1 finds the index of the first vector element of maximum absolute value. +*> +*> Based on ICAMAX from Level 1 BLAS. +*> The change is to use the 'genuine' absolute value. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of elements in the vector CX. +*> \endverbatim +*> +*> \param[in] CX +*> \verbatim +*> CX is COMPLEX array, dimension (N) +*> The vector CX. The ICMAX1 function returns the index of its first +*> element of maximum absolute value. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The spacing between successive values of CX. INCX >= 1. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date February 2014 +* +*> \ingroup complexOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Nick Higham for use with CLACON. +* +* ===================================================================== + INTEGER FUNCTION ICMAX1( N, CX, INCX ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* February 2014 +* +* .. Scalar Arguments .. + INTEGER INCX, N +* .. +* .. Array Arguments .. + COMPLEX CX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL SMAX + INTEGER I, IX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + ICMAX1 = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + ICMAX1 = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + SMAX = ABS(CX(1)) + DO I = 2,N + IF (ABS(CX(I)).GT.SMAX) THEN + ICMAX1 = I + SMAX = ABS(CX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + SMAX = ABS(CX(1)) + IX = IX + INCX + DO I = 2,N + IF (ABS(CX(IX)).GT.SMAX) THEN + ICMAX1 = I + SMAX = ABS(CX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN +* +* End of ICMAX1 +* + END diff --git a/math/lapack/src/main/fortran/ilaclc.f b/math/lapack/src/main/fortran/ilaclc.f new file mode 100644 index 0000000000..35d86d2307 --- /dev/null +++ b/math/lapack/src/main/fortran/ilaclc.f @@ -0,0 +1,118 @@ +*> \brief \b ILACLC scans a matrix for its last non-zero column. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILACLC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILACLC( M, N, A, LDA ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDA +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILACLC scans A for its last non-zero column. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexOTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION ILACLC( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER ( ZERO = (0.0E+0, 0.0E+0) ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( N.EQ.0 ) THEN + ILACLC = N + ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILACLC = N + ELSE +* Now scan each column from the end, returning with the first non-zero. + DO ILACLC = N, 1, -1 + DO I = 1, M + IF( A(I, ILACLC).NE.ZERO ) RETURN + END DO + END DO + END IF + RETURN + END diff --git a/math/lapack/src/main/fortran/ilaclr.f b/math/lapack/src/main/fortran/ilaclr.f new file mode 100644 index 0000000000..c2e0584bb9 --- /dev/null +++ b/math/lapack/src/main/fortran/ilaclr.f @@ -0,0 +1,121 @@ +*> \brief \b ILACLR scans a matrix for its last non-zero row. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILACLR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILACLR( M, N, A, LDA ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDA +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILACLR scans A for its last non-zero row. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexOTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION ILACLR( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER ( ZERO = (0.0E+0, 0.0E+0) ) +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( M.EQ.0 ) THEN + ILACLR = M + ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILACLR = M + ELSE +* Scan up each column tracking the last zero row seen. + ILACLR = 0 + DO J = 1, N + I=M + DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) + I=I-1 + ENDDO + ILACLR = MAX( ILACLR, I ) + END DO + END IF + RETURN + END diff --git a/math/lapack/src/main/fortran/iladiag.f b/math/lapack/src/main/fortran/iladiag.f new file mode 100644 index 0000000000..58614d2682 --- /dev/null +++ b/math/lapack/src/main/fortran/iladiag.f @@ -0,0 +1,92 @@ +*> \brief \b ILADIAG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILADIAG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILADIAG( DIAG ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This subroutine translated from a character string specifying if a +*> matrix has unit diagonal or not to the relevant BLAST-specified +*> integer constant. +*> +*> ILADIAG returns an INTEGER. If ILADIAG < 0, then the input is not a +*> character indicating a unit or non-unit diagonal. Otherwise ILADIAG +*> returns the constant value corresponding to DIAG. +*> \endverbatim +* +* Arguments: +* ========== +* +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + INTEGER FUNCTION ILADIAG( DIAG ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER DIAG +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER BLAS_NON_UNIT_DIAG, BLAS_UNIT_DIAG + PARAMETER ( BLAS_NON_UNIT_DIAG = 131, BLAS_UNIT_DIAG = 132 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. + IF( LSAME( DIAG, 'N' ) ) THEN + ILADIAG = BLAS_NON_UNIT_DIAG + ELSE IF( LSAME( DIAG, 'U' ) ) THEN + ILADIAG = BLAS_UNIT_DIAG + ELSE + ILADIAG = -1 + END IF + RETURN +* +* End of ILADIAG +* + END diff --git a/math/lapack/src/main/fortran/iladlc.f b/math/lapack/src/main/fortran/iladlc.f new file mode 100644 index 0000000000..c6476113d1 --- /dev/null +++ b/math/lapack/src/main/fortran/iladlc.f @@ -0,0 +1,118 @@ +*> \brief \b ILADLC scans a matrix for its last non-zero column. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILADLC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILADLC( M, N, A, LDA ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILADLC scans A for its last non-zero column. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION ILADLC( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( N.EQ.0 ) THEN + ILADLC = N + ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILADLC = N + ELSE +* Now scan each column from the end, returning with the first non-zero. + DO ILADLC = N, 1, -1 + DO I = 1, M + IF( A(I, ILADLC).NE.ZERO ) RETURN + END DO + END DO + END IF + RETURN + END diff --git a/math/lapack/src/main/fortran/iladlr.f b/math/lapack/src/main/fortran/iladlr.f new file mode 100644 index 0000000000..e8951d86cc --- /dev/null +++ b/math/lapack/src/main/fortran/iladlr.f @@ -0,0 +1,121 @@ +*> \brief \b ILADLR scans a matrix for its last non-zero row. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILADLR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILADLR( M, N, A, LDA ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILADLR scans A for its last non-zero row. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION ILADLR( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( M.EQ.0 ) THEN + ILADLR = M + ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILADLR = M + ELSE +* Scan up each column tracking the last zero row seen. + ILADLR = 0 + DO J = 1, N + I=M + DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) + I=I-1 + ENDDO + ILADLR = MAX( ILADLR, I ) + END DO + END IF + RETURN + END diff --git a/math/lapack/src/main/fortran/ilaprec.f b/math/lapack/src/main/fortran/ilaprec.f new file mode 100644 index 0000000000..f1f32ac4b2 --- /dev/null +++ b/math/lapack/src/main/fortran/ilaprec.f @@ -0,0 +1,98 @@ +*> \brief \b ILAPREC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILAPREC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILAPREC( PREC ) +* +* .. Scalar Arguments .. +* CHARACTER PREC +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This subroutine translated from a character string specifying an +*> intermediate precision to the relevant BLAST-specified integer +*> constant. +*> +*> ILAPREC returns an INTEGER. If ILAPREC < 0, then the input is not a +*> character indicating a supported intermediate precision. Otherwise +*> ILAPREC returns the constant value corresponding to PREC. +*> \endverbatim +* +* Arguments: +* ========== +* +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + INTEGER FUNCTION ILAPREC( PREC ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER PREC +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER BLAS_PREC_SINGLE, BLAS_PREC_DOUBLE, BLAS_PREC_INDIGENOUS, + $ BLAS_PREC_EXTRA + PARAMETER ( BLAS_PREC_SINGLE = 211, BLAS_PREC_DOUBLE = 212, + $ BLAS_PREC_INDIGENOUS = 213, BLAS_PREC_EXTRA = 214 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. + IF( LSAME( PREC, 'S' ) ) THEN + ILAPREC = BLAS_PREC_SINGLE + ELSE IF( LSAME( PREC, 'D' ) ) THEN + ILAPREC = BLAS_PREC_DOUBLE + ELSE IF( LSAME( PREC, 'I' ) ) THEN + ILAPREC = BLAS_PREC_INDIGENOUS + ELSE IF( LSAME( PREC, 'X' ) .OR. LSAME( PREC, 'E' ) ) THEN + ILAPREC = BLAS_PREC_EXTRA + ELSE + ILAPREC = -1 + END IF + RETURN +* +* End of ILAPREC +* + END diff --git a/math/lapack/src/main/fortran/ilaslc.f b/math/lapack/src/main/fortran/ilaslc.f new file mode 100644 index 0000000000..d7770fd4ba --- /dev/null +++ b/math/lapack/src/main/fortran/ilaslc.f @@ -0,0 +1,118 @@ +*> \brief \b ILASLC scans a matrix for its last non-zero column. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILASLC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILASLC( M, N, A, LDA ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDA +* .. +* .. Array Arguments .. +* REAL A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILASLC scans A for its last non-zero column. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup realOTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION ILASLC( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + REAL A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( N.EQ.0 ) THEN + ILASLC = N + ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILASLC = N + ELSE +* Now scan each column from the end, returning with the first non-zero. + DO ILASLC = N, 1, -1 + DO I = 1, M + IF( A(I, ILASLC).NE.ZERO ) RETURN + END DO + END DO + END IF + RETURN + END diff --git a/math/lapack/src/main/fortran/ilaslr.f b/math/lapack/src/main/fortran/ilaslr.f new file mode 100644 index 0000000000..910bc800d0 --- /dev/null +++ b/math/lapack/src/main/fortran/ilaslr.f @@ -0,0 +1,121 @@ +*> \brief \b ILASLR scans a matrix for its last non-zero row. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILASLR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILASLR( M, N, A, LDA ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDA +* .. +* .. Array Arguments .. +* REAL A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILASLR scans A for its last non-zero row. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup realOTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION ILASLR( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + REAL A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER ( ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( M.EQ.0 ) THEN + ILASLR = M + ELSEIF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILASLR = M + ELSE +* Scan up each column tracking the last zero row seen. + ILASLR = 0 + DO J = 1, N + I=M + DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) + I=I-1 + ENDDO + ILASLR = MAX( ILASLR, I ) + END DO + END IF + RETURN + END diff --git a/math/lapack/src/main/fortran/ilatrans.f b/math/lapack/src/main/fortran/ilatrans.f new file mode 100644 index 0000000000..6b90bfc765 --- /dev/null +++ b/math/lapack/src/main/fortran/ilatrans.f @@ -0,0 +1,95 @@ +*> \brief \b ILATRANS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILATRANS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILATRANS( TRANS ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This subroutine translates from a character string specifying a +*> transposition operation to the relevant BLAST-specified integer +*> constant. +*> +*> ILATRANS returns an INTEGER. If ILATRANS < 0, then the input is not +*> a character indicating a transposition operator. Otherwise ILATRANS +*> returns the constant value corresponding to TRANS. +*> \endverbatim +* +* Arguments: +* ========== +* +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + INTEGER FUNCTION ILATRANS( TRANS ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER TRANS +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER BLAS_NO_TRANS, BLAS_TRANS, BLAS_CONJ_TRANS + PARAMETER ( BLAS_NO_TRANS = 111, BLAS_TRANS = 112, + $ BLAS_CONJ_TRANS = 113 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. + IF( LSAME( TRANS, 'N' ) ) THEN + ILATRANS = BLAS_NO_TRANS + ELSE IF( LSAME( TRANS, 'T' ) ) THEN + ILATRANS = BLAS_TRANS + ELSE IF( LSAME( TRANS, 'C' ) ) THEN + ILATRANS = BLAS_CONJ_TRANS + ELSE + ILATRANS = -1 + END IF + RETURN +* +* End of ILATRANS +* + END diff --git a/math/lapack/src/main/fortran/ilauplo.f b/math/lapack/src/main/fortran/ilauplo.f new file mode 100644 index 0000000000..89bc9b225e --- /dev/null +++ b/math/lapack/src/main/fortran/ilauplo.f @@ -0,0 +1,92 @@ +*> \brief \b ILAUPLO +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILAUPLO + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILAUPLO( UPLO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This subroutine translated from a character string specifying a +*> upper- or lower-triangular matrix to the relevant BLAST-specified +*> integer constant. +*> +*> ILAUPLO returns an INTEGER. If ILAUPLO < 0, then the input is not +*> a character indicating an upper- or lower-triangular matrix. +*> Otherwise ILAUPLO returns the constant value corresponding to UPLO. +*> \endverbatim +* +* Arguments: +* ========== +* +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERcomputational +* +* ===================================================================== + INTEGER FUNCTION ILAUPLO( UPLO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER BLAS_UPPER, BLAS_LOWER + PARAMETER ( BLAS_UPPER = 121, BLAS_LOWER = 122 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. + IF( LSAME( UPLO, 'U' ) ) THEN + ILAUPLO = BLAS_UPPER + ELSE IF( LSAME( UPLO, 'L' ) ) THEN + ILAUPLO = BLAS_LOWER + ELSE + ILAUPLO = -1 + END IF + RETURN +* +* End of ILAUPLO +* + END diff --git a/math/lapack/src/main/fortran/ilaver.f b/math/lapack/src/main/fortran/ilaver.f new file mode 100644 index 0000000000..a99f727d52 --- /dev/null +++ b/math/lapack/src/main/fortran/ilaver.f @@ -0,0 +1,72 @@ +*> \brief \b ILAVER returns the LAPACK version. +** +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) +* +* INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This subroutine returns the LAPACK version. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[out] VERS_MAJOR +*> \verbatim +*> return the lapack major version +*> \endverbatim +*> +*> \param[out] VERS_MINOR +*> \verbatim +*> return the lapack minor version from the major version +*> \endverbatim +*> +*> \param[out] VERS_PATCH +*> \verbatim +*> return the lapack patch version from the minor version +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* ===================================================================== +* + INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH +* ===================================================================== + VERS_MAJOR = 3 + VERS_MINOR = 7 + VERS_PATCH = 0 +* ===================================================================== +* + RETURN + END diff --git a/math/lapack/src/main/fortran/ilazlc.f b/math/lapack/src/main/fortran/ilazlc.f new file mode 100644 index 0000000000..07dfc93e31 --- /dev/null +++ b/math/lapack/src/main/fortran/ilazlc.f @@ -0,0 +1,118 @@ +*> \brief \b ILAZLC scans a matrix for its last non-zero column. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILAZLC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILAZLC( M, N, A, LDA ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDA +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILAZLC scans A for its last non-zero column. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION ILAZLC( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( N.EQ.0 ) THEN + ILAZLC = N + ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILAZLC = N + ELSE +* Now scan each column from the end, returning with the first non-zero. + DO ILAZLC = N, 1, -1 + DO I = 1, M + IF( A(I, ILAZLC).NE.ZERO ) RETURN + END DO + END DO + END IF + RETURN + END diff --git a/math/lapack/src/main/fortran/ilazlr.f b/math/lapack/src/main/fortran/ilazlr.f new file mode 100644 index 0000000000..4ca4ed1a44 --- /dev/null +++ b/math/lapack/src/main/fortran/ilazlr.f @@ -0,0 +1,121 @@ +*> \brief \b ILAZLR scans a matrix for its last non-zero row. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILAZLR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILAZLR( M, N, A, LDA ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDA +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILAZLR scans A for its last non-zero row. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION ILAZLR( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( M.EQ.0 ) THEN + ILAZLR = M + ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILAZLR = M + ELSE +* Scan up each column tracking the last zero row seen. + ILAZLR = 0 + DO J = 1, N + I=M + DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) + I=I-1 + ENDDO + ILAZLR = MAX( ILAZLR, I ) + END DO + END IF + RETURN + END diff --git a/math/lapack/src/main/fortran/iparam2stage.F b/math/lapack/src/main/fortran/iparam2stage.F new file mode 100644 index 0000000000..0fc1795140 --- /dev/null +++ b/math/lapack/src/main/fortran/iparam2stage.F @@ -0,0 +1,386 @@ +*> \brief \b IPARAM2STAGE +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download IPARAM2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION IPARAM2STAGE( ISPEC, NAME, OPTS, +* NI, NBI, IBI, NXI ) +* #if defined(_OPENMP) +* use omp_lib +* #endif +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER*( * ) NAME, OPTS +* INTEGER ISPEC, NI, NBI, IBI, NXI +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This program sets problem and machine dependent parameters +*> useful for xHETRD_2STAGE, xHETRD_H@2HB, xHETRD_HB2ST, +*> xGEBRD_2STAGE, xGEBRD_GE2GB, xGEBRD_GB2BD +*> and related subroutines for eigenvalue problems. +*> It is called whenever ILAENV is called with 17 <= ISPEC <= 21 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is integer scalar +*> ISPEC specifies which tunable parameter IPARAM2STAGE should +*> return. +*> +*> ISPEC=17: the optimal blocksize nb for the reduction to +* BAND +*> +*> ISPEC=18: the optimal blocksize ib for the eigenvectors +*> singular vectors update routine +*> +*> ISPEC=19: The length of the array that store the Housholder +*> representation for the second stage +*> Band to Tridiagonal or Bidiagonal +*> +*> ISPEC=20: The workspace needed for the routine in input. +*> +*> ISPEC=21: For future release. +*> \endverbatim +*> +*> \param[in] NAME +*> \verbatim +*> NAME is character string +*> Name of the calling subroutine +*> \endverbatim +*> +*> \param[in] OPTS +*> \verbatim +*> OPTS is 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'. +*> \endverbatim +*> +*> \param[in] NI +*> \verbatim +*> NI is INTEGER which is the size of the matrix +*> \endverbatim +*> +*> \param[in] NBI +*> \verbatim +*> NBI is INTEGER which is the used in the reduciton, +* (e.g., the size of the band), needed to compute workspace +* and LHOUS2. +*> \endverbatim +*> +*> \param[in] IBI +*> \verbatim +*> IBI is INTEGER which represent the IB of the reduciton, +* needed to compute workspace and LHOUS2. +*> \endverbatim +*> +*> \param[in] NXI +*> \verbatim +*> NXI is INTEGER needed in the future release. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup auxOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All detail are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION IPARAM2STAGE( ISPEC, NAME, OPTS, + $ NI, NBI, IBI, NXI ) +#if defined(_OPENMP) + use omp_lib +#endif + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, NI, NBI, IBI, NXI +* +* ================================================================ +* .. +* .. Local Scalars .. + INTEGER I, IC, IZ, KD, IB, LHOUS, LWORK, NTHREADS, + $ FACTOPTNB, QROPTNB, LQOPTNB + LOGICAL RPREC, CPREC + CHARACTER PREC*1, ALGO*3, STAG*5, SUBNAM*12, VECT*3 +* .. +* .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, MAX +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Invalid value for ISPEC +* + IF( (ISPEC.LT.17).OR.(ISPEC.GT.21) ) THEN + IPARAM2STAGE = -1 + RETURN + ENDIF +* +* Get the number of threads +* + NTHREADS = 1 +#if defined(_OPENMP) +!$OMP PARALLEL + NTHREADS = OMP_GET_NUM_THREADS() +!$OMP END PARALLEL +#endif +* WRITE(*,*) 'IPARAM VOICI NTHREADS ISPEC ',NTHREADS, ISPEC +* + IF( ISPEC .NE. 19 ) THEN +* +* Convert NAME to upper case if the first character is lower case. +* + IPARAM2STAGE = -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 100 I = 2, 12 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 100 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 110 I = 2, 12 + 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 ) + 110 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 120 I = 2, 12 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 120 CONTINUE + END IF + END IF +* + PREC = SUBNAM( 1: 1 ) + ALGO = SUBNAM( 4: 6 ) + STAG = SUBNAM( 8:12 ) + RPREC = PREC.EQ.'S' .OR. PREC.EQ.'D' + CPREC = PREC.EQ.'C' .OR. PREC.EQ.'Z' +* +* Invalid value for PRECISION +* + IF( .NOT.( RPREC .OR. CPREC ) ) THEN + IPARAM2STAGE = -1 + RETURN + ENDIF + ENDIF +* WRITE(*,*),'RPREC,CPREC ',RPREC,CPREC, +* $ ' ALGO ',ALGO,' STAGE ',STAG +* +* + IF (( ISPEC .EQ. 17 ) .OR. ( ISPEC .EQ. 18 )) THEN +* +* ISPEC = 17, 18: block size KD, IB +* Could be also dependent from N but for now it +* depend only on sequential or parallel +* + IF( NTHREADS.GT.4 ) THEN + IF( CPREC ) THEN + KD = 128 + IB = 32 + ELSE + KD = 160 + IB = 40 + ENDIF + ELSE IF( NTHREADS.GT.1 ) THEN + IF( CPREC ) THEN + KD = 64 + IB = 32 + ELSE + KD = 64 + IB = 32 + ENDIF + ELSE + IF( CPREC ) THEN + KD = 16 + IB = 16 + ELSE + KD = 32 + IB = 16 + ENDIF + ENDIF + IF( ISPEC.EQ.17 ) IPARAM2STAGE = KD + IF( ISPEC.EQ.18 ) IPARAM2STAGE = IB +* + ELSE IF ( ISPEC .EQ. 19 ) THEN +* +* ISPEC = 19: +* LHOUS length of the Houselholder representation +* matrix (V,T) of the second stage. should be >= 1. +* +* Will add the VECT OPTION HERE next release + VECT = OPTS(1:1) + IF( VECT.EQ.'N' ) THEN + LHOUS = MAX( 1, 4*NI ) + ELSE +* This is not correct, it need to call the ALGO and the stage2 + LHOUS = MAX( 1, 4*NI ) + IBI + ENDIF + IF( LHOUS.GE.0 ) THEN + IPARAM2STAGE = LHOUS + ELSE + IPARAM2STAGE = -1 + ENDIF +* + ELSE IF ( ISPEC .EQ. 20 ) THEN +* +* ISPEC = 20: (21 for future use) +* LWORK length of the workspace for +* either or both stages for TRD and BRD. should be >= 1. +* TRD: +* TRD_stage 1: = LT + LW + LS1 + LS2 +* = LDT*KD + N*KD + N*MAX(KD,FACTOPTNB) + LDS2*KD +* where LDT=LDS2=KD +* = N*KD + N*max(KD,FACTOPTNB) + 2*KD*KD +* TRD_stage 2: = (2NB+1)*N + KD*NTHREADS +* TRD_both : = max(stage1,stage2) + AB ( AB=(KD+1)*N ) +* = N*KD + N*max(KD+1,FACTOPTNB) +* + max(2*KD*KD, KD*NTHREADS) +* + (KD+1)*N + LWORK = -1 + SUBNAM(1:1) = PREC + SUBNAM(2:6) = 'GEQRF' + QROPTNB = ILAENV( 1, SUBNAM, ' ', NI, NBI, -1, -1 ) + SUBNAM(2:6) = 'GELQF' + LQOPTNB = ILAENV( 1, SUBNAM, ' ', NBI, NI, -1, -1 ) +* Could be QR or LQ for TRD and the max for BRD + FACTOPTNB = MAX(QROPTNB, LQOPTNB) + IF( ALGO.EQ.'TRD' ) THEN + IF( STAG.EQ.'2STAG' ) THEN + LWORK = NI*NBI + NI*MAX(NBI+1,FACTOPTNB) + $ + MAX(2*NBI*NBI, NBI*NTHREADS) + $ + (NBI+1)*NI + ELSE IF( (STAG.EQ.'HE2HB').OR.(STAG.EQ.'SY2SB') ) THEN + LWORK = NI*NBI + NI*MAX(NBI,FACTOPTNB) + 2*NBI*NBI + ELSE IF( (STAG.EQ.'HB2ST').OR.(STAG.EQ.'SB2ST') ) THEN + LWORK = (2*NBI+1)*NI + NBI*NTHREADS + ENDIF + ELSE IF( ALGO.EQ.'BRD' ) THEN + IF( STAG.EQ.'2STAG' ) THEN + LWORK = 2*NI*NBI + NI*MAX(NBI+1,FACTOPTNB) + $ + MAX(2*NBI*NBI, NBI*NTHREADS) + $ + (NBI+1)*NI + ELSE IF( STAG.EQ.'GE2GB' ) THEN + LWORK = NI*NBI + NI*MAX(NBI,FACTOPTNB) + 2*NBI*NBI + ELSE IF( STAG.EQ.'GB2BD' ) THEN + LWORK = (3*NBI+1)*NI + NBI*NTHREADS + ENDIF + ENDIF + LWORK = MAX ( 1, LWORK ) + + IF( LWORK.GT.0 ) THEN + IPARAM2STAGE = LWORK + ELSE + IPARAM2STAGE = -1 + ENDIF +* + ELSE IF ( ISPEC .EQ. 21 ) THEN +* +* ISPEC = 21 for future use + IPARAM2STAGE = NXI + ENDIF +* +* ==== End of IPARAM2STAGE ==== +* + END diff --git a/math/lapack/src/main/fortran/izmax1.f b/math/lapack/src/main/fortran/izmax1.f new file mode 100644 index 0000000000..bec5c68ea7 --- /dev/null +++ b/math/lapack/src/main/fortran/izmax1.f @@ -0,0 +1,141 @@ +*> \brief \b IZMAX1 finds the index of the first vector element of maximum absolute value. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download IZMAX1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION IZMAX1( N, ZX, INCX ) +* +* .. Scalar Arguments .. +* INTEGER INCX, N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IZMAX1 finds the index of the first vector element of maximum absolute value. +*> +*> Based on IZAMAX from Level 1 BLAS. +*> The change is to use the 'genuine' absolute value. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of elements in the vector ZX. +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension (N) +*> The vector ZX. The IZMAX1 function returns the index of its first +*> element of maximum absolute value. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The spacing between successive values of ZX. INCX >= 1. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date February 2014 +* +*> \ingroup complexOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Nick Higham for use with ZLACON. +* +* ===================================================================== + INTEGER FUNCTION IZMAX1( N, ZX, INCX ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* February 2014 +* +* .. Scalar Arguments .. + INTEGER INCX, N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DMAX + INTEGER I, IX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + IZMAX1 = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + IZMAX1 = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DMAX = ABS(ZX(1)) + DO I = 2,N + IF (ABS(ZX(I)).GT.DMAX) THEN + IZMAX1 = I + DMAX = ABS(ZX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + DMAX = ABS(ZX(1)) + IX = IX + INCX + DO I = 2,N + IF (ABS(ZX(IX)).GT.DMAX) THEN + IZMAX1 = I + DMAX = ABS(ZX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN +* +* End of IZMAX1 +* + END diff --git a/math/lapack/src/main/fortran/xerbla.f b/math/lapack/src/main/fortran/xerbla.f new file mode 100644 index 0000000000..4a0350988c --- /dev/null +++ b/math/lapack/src/main/fortran/xerbla.f @@ -0,0 +1,99 @@ +*> \brief \b XERBLA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download XERBLA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE XERBLA( SRNAME, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER*(*) SRNAME +* INTEGER INFO +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SRNAME +*> \verbatim +*> SRNAME is CHARACTER*(*) +*> The name of the routine which called XERBLA. +*> \endverbatim +*> +*> \param[in] INFO +*> \verbatim +*> INFO is INTEGER +*> The position of the invalid parameter in the parameter list +*> of the calling routine. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + SUBROUTINE XERBLA( SRNAME, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER*(*) SRNAME + INTEGER INFO +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM +* .. +* .. Executable Statements .. +* + WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO +* + STOP +* + 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END diff --git a/math/lapack/src/main/fortran/xerbla_array.f b/math/lapack/src/main/fortran/xerbla_array.f new file mode 100644 index 0000000000..84fe7de9d8 --- /dev/null +++ b/math/lapack/src/main/fortran/xerbla_array.f @@ -0,0 +1,129 @@ +*> \brief \b XERBLA_ARRAY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download XERBLA_ARRAY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE XERBLA_ARRAY( SRNAME_ARRAY, SRNAME_LEN, INFO) +* +* .. Scalar Arguments .. +* INTEGER SRNAME_LEN, INFO +* .. +* .. Array Arguments .. +* CHARACTER(1) SRNAME_ARRAY(SRNAME_LEN) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK +*> and BLAS error handler. Rather than taking a Fortran string argument +*> as the function's name, XERBLA_ARRAY takes an array of single +*> characters along with the array's length. XERBLA_ARRAY then copies +*> up to 32 characters of that array into a Fortran string and passes +*> that to XERBLA. If called with a non-positive SRNAME_LEN, +*> XERBLA_ARRAY will call XERBLA with a string of all blank characters. +*> +*> Say some macro or other device makes XERBLA_ARRAY available to C99 +*> by a name lapack_xerbla and with a common Fortran calling convention. +*> Then a C99 program could invoke XERBLA via: +*> { +*> int flen = strlen(__func__); +*> lapack_xerbla(__func__, &flen, &info); +*> } +*> +*> Providing XERBLA_ARRAY is not necessary for intercepting LAPACK +*> errors. XERBLA_ARRAY calls XERBLA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SRNAME_ARRAY +*> \verbatim +*> SRNAME_ARRAY is CHARACTER(1) array, dimension (SRNAME_LEN) +*> The name of the routine which called XERBLA_ARRAY. +*> \endverbatim +*> +*> \param[in] SRNAME_LEN +*> \verbatim +*> SRNAME_LEN is INTEGER +*> The length of the name in SRNAME_ARRAY. +*> \endverbatim +*> +*> \param[in] INFO +*> \verbatim +*> INFO is INTEGER +*> The position of the invalid parameter in the parameter list +*> of the calling routine. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + SUBROUTINE XERBLA_ARRAY( SRNAME_ARRAY, SRNAME_LEN, INFO) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER SRNAME_LEN, INFO +* .. +* .. Array Arguments .. + CHARACTER(1) SRNAME_ARRAY(SRNAME_LEN) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. Local Arrays .. + CHARACTER*32 SRNAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN, LEN +* .. +* .. External Functions .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. + SRNAME = '' + DO I = 1, MIN( SRNAME_LEN, LEN( SRNAME ) ) + SRNAME( I:I ) = SRNAME_ARRAY( I ) + END DO + + CALL XERBLA( SRNAME, INFO ) + + RETURN + END diff --git a/tools/gcc-bridge/compiler/src/main/java/org/renjin/gcc/codegen/expr/ExprFactory.java b/tools/gcc-bridge/compiler/src/main/java/org/renjin/gcc/codegen/expr/ExprFactory.java index 6e59b477b7..ed6cd24b70 100644 --- a/tools/gcc-bridge/compiler/src/main/java/org/renjin/gcc/codegen/expr/ExprFactory.java +++ b/tools/gcc-bridge/compiler/src/main/java/org/renjin/gcc/codegen/expr/ExprFactory.java @@ -294,6 +294,7 @@ public GExpr findGenerator(GimpleOp op, List operands, GimpleType ex case RDIV_EXPR: case TRUNC_DIV_EXPR: case EXACT_DIV_EXPR: + case CEIL_DIV_EXPR: return findGenerator(operands.get(0)).toNumericExpr().divide(findGenerator(operands.get(1))); case TRUNC_MOD_EXPR: diff --git a/tools/gcc-bridge/compiler/src/main/java/org/renjin/gcc/gimple/GimpleOp.java b/tools/gcc-bridge/compiler/src/main/java/org/renjin/gcc/gimple/GimpleOp.java index a561abb9fb..e7b380d191 100644 --- a/tools/gcc-bridge/compiler/src/main/java/org/renjin/gcc/gimple/GimpleOp.java +++ b/tools/gcc-bridge/compiler/src/main/java/org/renjin/gcc/gimple/GimpleOp.java @@ -102,6 +102,13 @@ public String format(List operands) { } }, + CEIL_DIV_EXPR { + @Override + public String format(List operands) { + return GimpleOp.infix("/", operands); + } + }, + /** * Real Constant */ diff --git a/tools/gnur-compiler/src/main/java/org/renjin/gnur/GnurSourcesCompiler.java b/tools/gnur-compiler/src/main/java/org/renjin/gnur/GnurSourcesCompiler.java index ee123cbe46..ee4045c7ac 100644 --- a/tools/gnur-compiler/src/main/java/org/renjin/gnur/GnurSourcesCompiler.java +++ b/tools/gnur-compiler/src/main/java/org/renjin/gnur/GnurSourcesCompiler.java @@ -161,7 +161,6 @@ public void compile() throws Exception { public static void setupCompiler(GimpleCompiler compiler) throws ClassNotFoundException { compiler.addReferenceClass(Class.forName("org.renjin.appl.Appl")); compiler.addReferenceClass(Class.forName("org.renjin.math.Blas")); - compiler.addReferenceClass(Lapack.class); Class distributionsClass = Class.forName("org.renjin.stats.internals.Distributions"); compiler.addReferenceClass(distributionsClass); compiler.addMethod("Rf_dbeta", distributionsClass, "dbeta"); diff --git a/tools/gnur-runtime/src/main/java/org/renjin/gnur/api/Lapack.java b/tools/gnur-runtime/src/main/java/org/renjin/gnur/api/Lapack.java index 126baebfe6..737aaa0ad4 100644 --- a/tools/gnur-runtime/src/main/java/org/renjin/gnur/api/Lapack.java +++ b/tools/gnur-runtime/src/main/java/org/renjin/gnur/api/Lapack.java @@ -23,7 +23,7 @@ import org.renjin.gcc.runtime.DoublePtr; import org.renjin.gcc.runtime.IntPtr; -@SuppressWarnings("unused") +@Deprecated public final class Lapack { private Lapack() { }